diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 1ed98b6d9..75e0dd96a 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 4a6347a39..a3ac39ab7 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -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