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

fix(auth-caching): submission-group

Browse Source 
Also improve metrics wrt. auth tag eval
This commit is contained in:
Gregor Kleen 2021-03-11 16:22:52 +01:00
parent 57d6d0aba8
commit 896bd41e3b
2 changed files with 75 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

119
src/Foundation/Authorization.hs
View File

@ -34,6 +34,7 @@ import Handler.Utils.ExamOffice.ExternalExam
import Handler.Utils.Workflow.CanonicalRoute import Handler.Utils.Workflow.CanonicalRoute
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Handler.Utils.I18n import Handler.Utils.I18n
import Handler.Utils.Routes
import Utils.Course (courseIsVisible) import Utils.Course (courseIsVisible)
import Utils.Workflow import Utils.Workflow
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..)) import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
@ -94,7 +95,8 @@ data AccessPredicate
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX 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) | 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 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 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 (APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w (APHandler p) -> p aid r w
(APDB p) -> runDBRead' callStack $ p contCtx cont aid r w (APDB p) -> runDBRead' callStack $ p contCtx cont aid r w
(APCache p) -> do (APBind p) -> do
res <- p aid r w res <- p aid r w
case res of case res of
Right res' -> return res' Right res' -> return res'
Left p' -> evalAccessPred p' contCtx cont aid r w 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 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 evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p aid r w (APHandler p) -> lift $ p aid r w
(APDB p) -> p contCtx cont aid r w (APDB p) -> p contCtx cont aid r w
(APCache p) -> do (APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> lift $ p aid' r' w') contCtx cont aid r w
res <- lift $ p aid r w (APBindDB p) -> do
res <- p aid r w
case res of case res of
Right res' -> return res' Right res' -> return res'
Left p' -> evalAccessPred p' contCtx cont aid r w Left p' -> evalAccessPred p' contCtx cont aid r w
@ -129,7 +133,17 @@ cacheAP :: ( Binary k
-> HandlerFor UniWorX v -> HandlerFor UniWorX v
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
-> AccessPredicate -> 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 cacheAP' :: ( Binary k
, Typeable v, Binary v , Typeable v, Binary v
@ -138,10 +152,21 @@ cacheAP' :: ( Binary k
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v)) -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult)) -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
-> AccessPredicate -> 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 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 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 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR _ Authorized _ = Authorized orAR _ Authorized _ = Authorized
@ -373,6 +398,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
data AuthorizationCacheKey data AuthorizationCacheKey
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope
| AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction | AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
| AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList | AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
@ -757,39 +783,32 @@ tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
guard tutorialTutorControlled guard tutorialTutorControlled
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTutorControl r r -> $unsupportedAuthPredicate AuthTutorControl r
tagAccessPredicate AuthSubmissionGroup = cacheAP (Just $ Right diffMinute) AuthCacheSubmissionGroupUserList mkSubmissionGroupUserList $ \mAuthId' route' _ submissionGroupUserList -> if tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
| maybe True (`Set.notMember` submissionGroupUserList) mAuthId' -> Right $ case route' of CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
_ | is _Nothing mAuthId' -> return AuthenticationRequired course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (course, shn) . getBy $ CourseSheet course shn
CSheetR{} -> unauthorizedI MsgUnauthorizedSheetSubmissionGroup when (is _RegisteredGroups sheetGrouping) $ do
r -> $unsupportedAuthPredicate AuthSubmissionGroup r smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID unless (Set.null groups) $ do
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do uid <- hoistMaybe mAuthId
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId return Authorized
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
uid <- hoistMaybe mAuthId Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] when (is _RegisteredGroups sheetGrouping) $ do
return Authorized uid <- hoistMaybe mAuthId
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
when (is _RegisteredGroups sheetGrouping) $ do E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
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 return Authorized
r -> $unsupportedAuthPredicate AuthSubmissionGroup r r -> $unsupportedAuthPredicate AuthSubmissionGroup r
where
mkSubmissionGroupUserList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SubmissionGroupUserUser)
tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh 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) 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 roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
let wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
edges = do return . fold $ do
WGN{..} <- wiGraph ^.. _wgNodes . folded WGN{..} <- wiGraph ^.. _wgNodes . folded
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
hoistMaybe . fromNullable $ wgeActors ^.. folded return wgeActors
let let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ toList roles)
checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
return AuthorizedI18n return AuthorizedI18n
wWorkflow isWrite' cID wWorkflow isWrite' cID
@ -1619,7 +1636,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
let let
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' 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 edges) guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
return Authorized return Authorized
| otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
(wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do (wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
@ -1645,7 +1662,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
let let
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' 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 roles) guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
return Authorized return Authorized
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
@ -1723,7 +1740,7 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
where where
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
observeAuthTagEvaluation authTag' $ do observeAuthTagEvaluation authTag' (classifyHandler route') $ do
res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite' res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
return . (res, ) $ case res of return . (res, ) $ case res of
Authorized -> OutcomeAuthorized Authorized -> OutcomeAuthorized

12
src/Utils/Metrics.hs
View File

@ -431,12 +431,12 @@ data AuthTagEvalOutcome = OutcomeAuthorized | OutcomeUnauthorized | OutcomeAuthe
nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1 nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1
{-# NOINLINE authTagEvaluationDuration #-} {-# NOINLINE authTagEvaluationDuration #-}
authTagEvaluationDuration :: Vector Label2 Histogram authTagEvaluationDuration :: Vector Label3 Histogram
authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome") $ histogram info buckets authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler") $ histogram info buckets
where where
info = Info "uni2work_auth_tag_evaluation_duration_seconds" info = Info "uni2work_auth_tag_evaluation_duration_seconds"
"Duration of auth tag evaluations" "Duration of auth tag evaluations"
buckets = histogramBuckets 50e-6 1 buckets = histogramBuckets 5e-6 1
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
@ -586,8 +586,8 @@ observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m =>
observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened
observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed
observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> m (a, AuthTagEvalOutcome) -> m a observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> String -> m (a, AuthTagEvalOutcome) -> m a
observeAuthTagEvaluation aTag act = do observeAuthTagEvaluation aTag handler act = do
start <- liftIO $ getTime Monotonic start <- liftIO $ getTime Monotonic
res <- tryAny act res <- tryAny act
end <- liftIO $ getTime Monotonic end <- liftIO $ getTime Monotonic
@ -596,7 +596,7 @@ observeAuthTagEvaluation aTag act = do
Right (_, outcome') -> outcome' Right (_, outcome') -> outcome'
Left _ -> OutcomeException 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 either throwIO (views _1 return) res