fix(auth-caching): submission-group
Also improve metrics wrt. auth tag eval
This commit is contained in:
Gregor Kleen
parent
57d6d0aba8
commit
896bd41e3b
@ -34,6 +34,7 @@ import Handler.Utils.ExamOffice.ExternalExam
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
import Handler.Utils.Memcached
|
||||
import Handler.Utils.I18n
|
||||
import Handler.Utils.Routes
|
||||
import Utils.Course (courseIsVisible)
|
||||
import Utils.Workflow
|
||||
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
|
||||
@ -94,7 +95,8 @@ data AccessPredicate
|
||||
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
|
||||
| APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
|
||||
| APCache (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
|
||||
| APBind (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
|
||||
| APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult))
|
||||
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
|
||||
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
||||
@ -104,19 +106,21 @@ instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuth
|
||||
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p aid r w
|
||||
(APDB p) -> runDBRead' callStack $ p contCtx cont aid r w
|
||||
(APCache p) -> do
|
||||
(APBind p) -> do
|
||||
res <- p aid r w
|
||||
case res of
|
||||
Right res' -> return res'
|
||||
Left p' -> evalAccessPred p' contCtx cont aid r w
|
||||
(APBindDB p) -> evalAccessPred (APBind $ \aid' r' w' -> runDBRead' callStack $ p aid' r' w') contCtx cont aid r w
|
||||
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where
|
||||
evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
|
||||
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p aid r w
|
||||
(APDB p) -> p contCtx cont aid r w
|
||||
(APCache p) -> do
|
||||
res <- lift $ p aid r w
|
||||
(APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> lift $ p aid' r' w') contCtx cont aid r w
|
||||
(APBindDB p) -> do
|
||||
res <- p aid r w
|
||||
case res of
|
||||
Right res' -> return res'
|
||||
Left p' -> evalAccessPred p' contCtx cont aid r w
|
||||
@ -129,8 +133,18 @@ cacheAP :: ( Binary k
|
||||
-> HandlerFor UniWorX v
|
||||
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
||||
-> AccessPredicate
|
||||
cacheAP mExp k mkV cont = APCache $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
|
||||
|
||||
cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
|
||||
|
||||
-- cacheAPDB :: ( Binary k
|
||||
-- , Typeable v, Binary v
|
||||
-- )
|
||||
-- => Maybe Expiry
|
||||
-- -> k
|
||||
-- -> ReaderT SqlReadBackend (HandlerFor UniWorX) v
|
||||
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult))
|
||||
-- -> AccessPredicate
|
||||
-- cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
|
||||
|
||||
cacheAP' :: ( Binary k
|
||||
, Typeable v, Binary v
|
||||
)
|
||||
@ -138,9 +152,20 @@ cacheAP' :: ( Binary k
|
||||
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
|
||||
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
||||
-> AccessPredicate
|
||||
cacheAP' mExp mkKV cont = APCache $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
|
||||
cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
|
||||
Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
|
||||
Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
|
||||
|
||||
-- cacheAPDB' :: ( Binary k
|
||||
-- , Typeable v, Binary v
|
||||
-- )
|
||||
-- => Maybe Expiry
|
||||
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v))
|
||||
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult))
|
||||
-- -> AccessPredicate
|
||||
-- cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
|
||||
-- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
|
||||
-- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
|
||||
|
||||
|
||||
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
|
||||
@ -373,6 +398,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
|
||||
data AuthorizationCacheKey
|
||||
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope
|
||||
| AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
|
||||
| AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
|
||||
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
|
||||
@ -757,39 +783,32 @@ tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
|
||||
guard tutorialTutorControlled
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthTutorControl r
|
||||
tagAccessPredicate AuthSubmissionGroup = cacheAP (Just $ Right diffMinute) AuthCacheSubmissionGroupUserList mkSubmissionGroupUserList $ \mAuthId' route' _ submissionGroupUserList -> if
|
||||
| maybe True (`Set.notMember` submissionGroupUserList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup
|
||||
CSheetR{} -> unauthorizedI MsgUnauthorizedSheetSubmissionGroup
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
|
||||
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
|
||||
return Authorized
|
||||
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
|
||||
when (is _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
|
||||
course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (course, shn) . getBy $ CourseSheet course shn
|
||||
when (is _RegisteredGroups sheetGrouping) $ do
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
|
||||
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
unless (Set.null groups) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
|
||||
return Authorized
|
||||
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
|
||||
when (is _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
where
|
||||
mkSubmissionGroupUserList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SubmissionGroupUserUser)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -1587,18 +1606,16 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
|
||||
|
||||
|
||||
wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write)
|
||||
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
|
||||
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
|
||||
let
|
||||
edges = do
|
||||
roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do
|
||||
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
|
||||
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
|
||||
return . fold $ do
|
||||
WGN{..} <- wiGraph ^.. _wgNodes . folded
|
||||
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
|
||||
hoistMaybe . fromNullable $ wgeActors ^.. folded
|
||||
let
|
||||
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 wgeActors
|
||||
let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ toList roles)
|
||||
return AuthorizedI18n
|
||||
|
||||
wWorkflow isWrite' cID
|
||||
@ -1619,7 +1636,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
|
||||
|
||||
let
|
||||
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
|
||||
return Authorized
|
||||
| otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
|
||||
(wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
|
||||
@ -1645,7 +1662,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
|
||||
|
||||
let
|
||||
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
|
||||
return Authorized
|
||||
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
|
||||
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
|
||||
@ -1723,7 +1740,7 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
|
||||
where
|
||||
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
|
||||
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
|
||||
observeAuthTagEvaluation authTag' $ do
|
||||
observeAuthTagEvaluation authTag' (classifyHandler route') $ do
|
||||
res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
|
||||
return . (res, ) $ case res of
|
||||
Authorized -> OutcomeAuthorized
|
||||
|
||||
@ -431,12 +431,12 @@ data AuthTagEvalOutcome = OutcomeAuthorized | OutcomeUnauthorized | OutcomeAuthe
|
||||
nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1
|
||||
|
||||
{-# NOINLINE authTagEvaluationDuration #-}
|
||||
authTagEvaluationDuration :: Vector Label2 Histogram
|
||||
authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome") $ histogram info buckets
|
||||
authTagEvaluationDuration :: Vector Label3 Histogram
|
||||
authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler") $ histogram info buckets
|
||||
where
|
||||
info = Info "uni2work_auth_tag_evaluation_duration_seconds"
|
||||
"Duration of auth tag evaluations"
|
||||
buckets = histogramBuckets 50e-6 1
|
||||
buckets = histogramBuckets 5e-6 1
|
||||
|
||||
|
||||
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
|
||||
@ -586,8 +586,8 @@ observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m =>
|
||||
observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened
|
||||
observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed
|
||||
|
||||
observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> m (a, AuthTagEvalOutcome) -> m a
|
||||
observeAuthTagEvaluation aTag act = do
|
||||
observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> String -> m (a, AuthTagEvalOutcome) -> m a
|
||||
observeAuthTagEvaluation aTag handler act = do
|
||||
start <- liftIO $ getTime Monotonic
|
||||
res <- tryAny act
|
||||
end <- liftIO $ getTime Monotonic
|
||||
@ -596,7 +596,7 @@ observeAuthTagEvaluation aTag act = do
|
||||
Right (_, outcome') -> outcome'
|
||||
Left _ -> OutcomeException
|
||||
|
||||
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome) . flip observe . realToFrac $ end - start
|
||||
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start
|
||||
|
||||
either throwIO (views _1 return) res
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user