fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(auth): fix infinite auth loop for workflow files

Browse Source
This commit is contained in:
Gregor Kleen 2020-12-06 20:12:04 +01:00
parent 12c9513f96
commit 21cf6cfa87
3 changed files with 72 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
config/settings.yml
View File

@ -13,8 +13,8 @@ port: "_env:PORT:3000"
ip-from-header: "_env:IP_FROM_HEADER:false" ip-from-header: "_env:IP_FROM_HEADER:false"
approot: "_env:APPROOT:http://localhost:3000" approot: "_env:APPROOT:http://localhost:3000"
# approot: # approot:
# default: "https://localhost:3444" # default: "http://localhost:3000"
# user-generated: "https://127.0.0.1:3444" # user-generated: "http://127.0.0.1:3000"
mail-from: mail-from:
name: "_env:MAILFROM_NAME:Uni2work" name: "_env:MAILFROM_NAME:Uni2work"
email: "_env:MAILFROM_EMAIL:uniworx@localhost" email: "_env:MAILFROM_EMAIL:uniworx@localhost"

89
src/Foundation/Authorization.hs
View File

@ -16,7 +16,7 @@ module Foundation.Authorization
, orAR, andAR, notAR, trueAR, falseAR , orAR, andAR, notAR, trueAR, falseAR
, evalWorkflowRoleFor, evalWorkflowRoleFor' , evalWorkflowRoleFor, evalWorkflowRoleFor'
, hasWorkflowRole , hasWorkflowRole
, mayViewWorkflowAction , mayViewWorkflowAction, mayViewWorkflowAction'
, authoritiveApproot , authoritiveApproot
) where ) where
@ -151,7 +151,7 @@ getAuthContext :: forall m.
=> m AuthContext => m AuthContext
getAuthContext = liftHandler $ do getAuthContext = liftHandler $ do
authCtx <- AuthContext authCtx <- AuthContext
<$> maybeAuthId <$> defaultMaybeAuthId
<*> runMaybeT (exceptTMaybe askBearerUnsafe) <*> runMaybeT (exceptTMaybe askBearerUnsafe)
<*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags) <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
@ -172,7 +172,7 @@ isDryRun = $cachedHere . liftHandler $ orM
where where
bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
mAuthId <- maybeAuthId mAuthId <- defaultMaybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute isWrite <- isWriteRequest currentRoute
@ -182,7 +182,7 @@ isDryRun = $cachedHere . liftHandler $ orM
dnf <- either throwM return $ routeAuthTags currentRoute dnf <- either throwM return $ routeAuthTags currentRoute
let eval :: forall m'. MonadAP m' => AuthTagsEval m' let eval :: forall m'. MonadAP m' => AuthTagsEval m'
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite' eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
in guardAuthResult <=< fmap fst . runWriterT $ eval dnf mAuthId currentRoute isWrite in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
return False return False
@ -261,12 +261,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
authorityVal <- do authorityVal <- do
dnf <- either throwM return $ routeAuthTags route dnf <- either throwM return $ routeAuthTags route
fmap fst . runWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
guardExceptT (is _Authorized authorityVal) authorityVal guardExceptT (is _Authorized authorityVal) authorityVal
whenIsJust bearerAddAuth $ \addDNF -> do whenIsJust bearerAddAuth $ \addDNF -> do
$logDebugS "validateToken" $ tshow addDNF $logDebugS "validateToken" $ tshow addDNF
additionalVal <- fmap fst . runWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite additionalVal <- evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite
guardExceptT (is _Authorized additionalVal) additionalVal guardExceptT (is _Authorized additionalVal) additionalVal
return Authorized return Authorized
@ -1375,7 +1375,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route
guard $ not systemMessageAuthenticatedOnly || isAuthenticated guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
mr <- getMsgRenderer mr <- getMsgRenderer
let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr) orAR' = shortCircuitM (is _Authorized) (orAR mr)
@ -1392,7 +1392,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
hoistMaybe . fromNullable $ wgeActors ^.. folded hoistMaybe . fromNullable $ wgeActors ^.. folded
let let
evalRole role = lift $ evalWorkflowRoleFor mAuthId Nothing role route isWrite evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return Authorized return Authorized
@ -1414,7 +1414,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
guard $ wgeSource == wwNode guard $ wgeSource == wwNode
hoistMaybe . fromNullable $ wgeActors ^.. folded hoistMaybe . fromNullable $ wgeActors ^.. folded
evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors) checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges) guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return Authorized return Authorized
@ -1439,7 +1439,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act) guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph) fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers) guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers)
return Authorized return Authorized
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
@ -1453,9 +1453,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
let let
cState = wpTo act cState = wpTo act
payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> Map.findWithDefault Map.empty cState (wgnPayloadView <$> wgNodes wwGraph) payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> Map.findWithDefault Map.empty cState (wgnPayloadView <$> wgNodes wwGraph)
evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
guardM . anyM (otoList payloadViewers) $ fmap (is _Authorized) . evalRole guardM . anyM (otoList payloadViewers) $ fmap (is _Authorized) . evalRole
guardM . lift $ mayViewWorkflowAction mAuthId wwId act guardM . lift . evalWriterT $ mayViewWorkflowAction' eval' mAuthId wwId act
return Authorized return Authorized
case route of case route of
@ -1473,7 +1473,7 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
runTACont :: forall m. MonadAP m runTACont :: forall m. MonadAP m
=> (forall m'. MonadAP m' => AuthTagsEval m') => (forall m'. MonadAP m' => AuthTagsEval m')
-> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool
runTACont cont dnf mAuthId route isWrite = is _Authorized . fst <$> runWriterT (cont dnf mAuthId route isWrite) runTACont cont dnf mAuthId route isWrite = is _Authorized <$> evalWriterT (cont dnf mAuthId route isWrite)
authTagSpecificity :: AuthTag -> AuthTag -> Ordering authTagSpecificity :: AuthTag -> AuthTag -> Ordering
@ -1550,7 +1550,7 @@ evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toL
evalAccessWithFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessWithFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessWithFor assumptions mAuthId route isWrite = do evalAccessWithFor assumptions mAuthId route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler maybeAuthId isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if tagActive <- if
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
| otherwise -> return . AuthTagActive $ const True | otherwise -> return . AuthTagActive $ const True
@ -1686,7 +1686,7 @@ evalWorkflowRoleFor :: ( MonadHandler m
-> Bool -> Bool
-> ReaderT backend m AuthResult -> ReaderT backend m AuthResult
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler maybeAuthId isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if tagActive <- if
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
| otherwise -> return . AuthTagActive $ const True | otherwise -> return . AuthTagActive $ const True
@ -1712,6 +1712,36 @@ hasWorkflowRole mwwId wRole route isWrite = do
mAuthId <- maybeAuthId mAuthId <- maybeAuthId
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite evalWorkflowRoleFor mAuthId mwwId wRole route isWrite
mayViewWorkflowAction' :: forall backend m fileid.
( MonadHandler m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m
)
=> (forall m'. MonadAP m' => AuthTagsEval m')
-> Maybe UserId
-> WorkflowWorkflowId
-> WorkflowAction fileid UserId
-> WriterT (Set AuthTag) (ReaderT backend m) Bool
mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId
let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
guardM $ orM
[ return $ is _Just mAuthId && wpUser == Just mAuthId
, anyM wnvViewers evalWorkflowRole''
, anyM (Map.keys wpPayload) $ \payloadLbl -> lift . maybeT (return False) $ do
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
anyM wpvViewers evalWorkflowRole''
]
return True
mayViewWorkflowAction :: forall backend m fileid. mayViewWorkflowAction :: forall backend m fileid.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
@ -1724,22 +1754,19 @@ mayViewWorkflowAction :: forall backend m fileid.
-> WorkflowWorkflowId -> WorkflowWorkflowId
-> WorkflowAction fileid UserId -> WorkflowAction fileid UserId
-> ReaderT backend m Bool -> ReaderT backend m Bool
mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do mayViewWorkflowAction mAuthId wwId act = do
WorkflowWorkflow{..} <- MaybeT $ get wwId isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope tagActive <- if
cID <- catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId | isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph | otherwise -> return . AuthTagActive $ const True
canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) (result, deactivated) <-
evalWorkflowRole' role = lift $ is _Authorized <$> evalWorkflowRoleFor mAuthId (Just wwId) role canonRoute False let eval :: forall m'. MonadAP m' => AuthTagsEval m'
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers eval dnf' mAuthId' route' isWrite' = evalAuthTags 'mayViewWorkflowAction tagActive eval dnf' mAuthId' route' isWrite'
guardM $ orM in runWriterT $ mayViewWorkflowAction' eval mAuthId wwId act
[ return $ is _Just mAuthId && wpUser == Just mAuthId when isSelf $
, anyM wnvViewers evalWorkflowRole' tellSessionJson SessionInactiveAuthTags deactivated
, anyM (Map.keys wpPayload) $ \payloadLbl -> maybeT (return False) $ do return result
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
lift $ anyM wpvViewers evalWorkflowRole'
]
return True
authoritiveApproot :: Route UniWorX -> ApprootScope authoritiveApproot :: Route UniWorX -> ApprootScope
authoritiveApproot = \case authoritiveApproot = \case

12
src/Utils.hs
View File

@ -60,6 +60,8 @@ import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..)) import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..)) import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Trans.Writer.Strict (execWriterT) import Control.Monad.Trans.Writer.Strict (execWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch import Control.Monad.Catch
import Control.Monad.Morph (hoist) import Control.Monad.Morph (hoist)
@ -926,6 +928,16 @@ tellPoint = tell . opoint
tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m () tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
tellMPoint = tellM . fmap opoint tellMPoint = tellM . fmap opoint
class IsWriterT t where
runWriterT' :: (Monad m, Monoid w) => t w m a -> m (a, w)
instance IsWriterT Strict.WriterT where
runWriterT' = Strict.runWriterT
instance IsWriterT Lazy.WriterT where
runWriterT' = Lazy.runWriterT
evalWriterT :: (IsWriterT t, Monoid w, Monad m) => t w m a -> m a
evalWriterT = fmap fst . runWriterT'
------------- -------------
-- Conduit -- -- Conduit --
------------- -------------