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"
approot: "_env:APPROOT:http://localhost:3000"
# approot:
# default: "https://localhost:3444"
# user-generated: "https://127.0.0.1:3444"
# default: "http://localhost:3000"
# user-generated: "http://127.0.0.1:3000"
mail-from:
name: "_env:MAILFROM_NAME:Uni2work"
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
, evalWorkflowRoleFor, evalWorkflowRoleFor'
, hasWorkflowRole
, mayViewWorkflowAction
, mayViewWorkflowAction, mayViewWorkflowAction'
, authoritiveApproot
) where
@ -151,7 +151,7 @@ getAuthContext :: forall m.
=> m AuthContext
getAuthContext = liftHandler $ do
authCtx <- AuthContext
<$> maybeAuthId
<$> defaultMaybeAuthId
<*> runMaybeT (exceptTMaybe askBearerUnsafe)
<*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
@ -172,7 +172,7 @@ isDryRun = $cachedHere . liftHandler $ orM
where
bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
mAuthId <- maybeAuthId
mAuthId <- defaultMaybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
@ -182,7 +182,7 @@ isDryRun = $cachedHere . liftHandler $ orM
dnf <- either throwM return $ routeAuthTags currentRoute
let eval :: forall m'. MonadAP m' => AuthTagsEval m'
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
@ -261,12 +261,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
authorityVal <- do
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
whenIsJust bearerAddAuth $ \addDNF -> do
$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
return Authorized
@ -1375,7 +1375,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
tagAccessPredicate AuthWorkflow = APDB $ \eval' mAuthId route isWrite -> do
mr <- getMsgRenderer
let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr)
@ -1392,7 +1392,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
hoistMaybe . fromNullable $ wgeActors ^.. folded
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)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return Authorized
@ -1414,7 +1414,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
guard $ wgeSource == wwNode
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)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return Authorized
@ -1439,7 +1439,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
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)
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)
return Authorized
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
@ -1453,9 +1453,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
let
cState = wpTo act
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 . lift $ mayViewWorkflowAction mAuthId wwId act
guardM . lift . evalWriterT $ mayViewWorkflowAction' eval' mAuthId wwId act
return Authorized
case route of
@ -1473,7 +1473,7 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
runTACont :: forall m. MonadAP m
=> (forall m'. MonadAP m' => AuthTagsEval m')
-> 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
@ -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 assumptions mAuthId route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler maybeAuthId
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
| otherwise -> return . AuthTagActive $ const True
@ -1686,7 +1686,7 @@ evalWorkflowRoleFor :: ( MonadHandler m
-> Bool
-> ReaderT backend m AuthResult
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler maybeAuthId
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
| otherwise -> return . AuthTagActive $ const True
@ -1712,6 +1712,36 @@ hasWorkflowRole mwwId wRole route isWrite = do
mAuthId <- maybeAuthId
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.
( MonadHandler m
, HandlerSite m ~ UniWorX
@ -1724,22 +1754,19 @@ mayViewWorkflowAction :: forall backend m fileid.
-> WorkflowWorkflowId
-> WorkflowAction fileid UserId
-> ReaderT backend m Bool
mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
WorkflowWorkflow{..} <- MaybeT $ get wwId
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId
let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
evalWorkflowRole' role = lift $ is _Authorized <$> evalWorkflowRoleFor 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 -> maybeT (return False) $ do
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
lift $ anyM wpvViewers evalWorkflowRole'
]
return True
mayViewWorkflowAction mAuthId wwId act = do
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
| otherwise -> return . AuthTagActive $ const True
(result, deactivated) <-
let eval :: forall m'. MonadAP m' => AuthTagsEval m'
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'mayViewWorkflowAction tagActive eval dnf' mAuthId' route' isWrite'
in runWriterT $ mayViewWorkflowAction' eval mAuthId wwId act
when isSelf $
tellSessionJson SessionInactiveAuthTags deactivated
return result
authoritiveApproot :: Route UniWorX -> ApprootScope
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.Trans.Maybe as Utils (MaybeT(..))
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.Catch
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 = 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 --
-------------