From 6fbef0433c53419bd257b7714fe7fb1a1e847b2d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 12 Mar 2021 14:59:38 +0100 Subject: [PATCH] perf: additional/improved auth caching --- src/Database/Persist/Sql/Types/Instances.hs | 4 + src/Foundation/Authorization.hs | 155 ++++++++++++-------- src/Handler/Workflow/Instance/Initiate.hs | 2 + src/Handler/Workflow/Workflow/Workflow.hs | 11 +- 4 files changed, 106 insertions(+), 66 deletions(-) diff --git a/src/Database/Persist/Sql/Types/Instances.hs b/src/Database/Persist/Sql/Types/Instances.hs index b7c33572b..cc7219bc3 100644 --- a/src/Database/Persist/Sql/Types/Instances.hs +++ b/src/Database/Persist/Sql/Types/Instances.hs @@ -8,6 +8,8 @@ import ClassyPrelude import Database.Persist.Sql +import Data.Binary (Binary) + instance BackendCompatible SqlWriteBackend SqlWriteBackend where projectBackend = id @@ -20,3 +22,5 @@ instance BackendCompatible SqlReadBackend SqlBackend where instance BackendCompatible SqlWriteBackend SqlBackend where projectBackend = SqlWriteBackend + +deriving newtype instance Binary (BackendKey SqlBackend) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 75e0dd96a..bb2f35ad2 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -399,6 +399,7 @@ data AuthorizationCacheKey = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope + | AuthCacheWorkflowInstanceWorkflowViewers WorkflowInstanceName RouteWorkflowScope | AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction | AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand @@ -672,7 +673,7 @@ tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerL , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser) ) tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if - | maybe False (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of + | maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector @@ -680,31 +681,35 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo _other -> unauthorizedI MsgUnauthorizedCorrectorAny | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId - return (course E.^. CourseId, sheet E.^. SheetId) - let - resMap :: Map CourseId (Set SheetId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSubmissionR _ _ _ _ cID _ -> lift . $cachedHereBinary (authId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - Submission{..} <- MaybeT . lift $ get sid - guard $ Just authId == submissionRatingBy + guardM . lift . E.selectExists . E.from $ \submission -> + E.where_ $ submission E.^. SubmissionId E.==. E.val sid + E.&&. submission E.^. SubmissionRatingBy E.==. E.justVal authId return Authorized - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn - guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) + CSheetR tid ssh csh shn _ -> lift . $cachedHereBinary (authId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap + CourseR tid ssh csh _ -> lift . $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) + _ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do + guardM . lift . E.selectExists . E.from $ \sheetCorrector -> + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId return Authorized where mkCorrectorList = runDBRead . execWriterT $ do @@ -713,7 +718,7 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo return $ submission E.^. SubmissionRatingBy tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser) tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if - | maybe False (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of + | maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector @@ -746,7 +751,7 @@ tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCac where mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser) tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if - | maybe False (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of + | maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of _ | is _Nothing mAuthId' -> return AuthenticationRequired CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor @@ -1445,47 +1450,69 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route guard $ not hasOther return Authorized r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ - -> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do - scope <- fromRouteWorkflowScope rScope - let dbScope = scope ^. _DBWorkflowScope - getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do - E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId) - E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win - E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope - return ( workflowWorkflow E.^. WorkflowWorkflowId - , workflowWorkflow E.^. WorkflowWorkflowScope - ) - checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do - cID <- encrypt wwId - rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope - guardM . lift . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) - return True - guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or - return AuthorizedI18n - in case route of - r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute - -> workflowInstanceWorkflowsEmpty rScope win - EExamListR -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam - E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId - E.||. E.exists (E.from $ \externalExamResult -> - E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId - E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId - ) - guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do - -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return Authorized - r -> $unsupportedAuthPredicate AuthEmpty r +tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do + mr <- getMsgRenderer + let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + _andAR' = shortCircuitM (is _Unauthorized) (andAR mr) + + workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do + roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do + scope <- fromRouteWorkflowScope rScope + let dbScope = scope ^. _DBWorkflowScope + getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do + E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId) + E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win + E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope + return workflowWorkflow + workflowRoles (Entity wwId WorkflowWorkflow{..}) = do + wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph + let + nodeViewers = do + WorkflowAction{..} <- otoList workflowWorkflowState + (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph + guard $ node == wpTo + WorkflowNodeView{..} <- hoistMaybe wgnViewers + return $ toNullable wnvViewers + payloadViewers = do + (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState + prevAct <- hoistMaybe $ prevActs ^? _last + payload <- Map.keys $ 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) + return . Set.mapMonotonic ((workflowWorkflowScope, wwId), ) $ fold nodeViewers <> fold payloadViewers + lift . runConduit $ getWorkflowWorkflows .| C.foldMapM workflowRoles + let + evalRole ((wwScope, wwId), role) = do + rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope + cID <- encrypt wwId + let route' = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) + lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route' False + guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles) + return AuthorizedI18n + in case route of + r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute + -> workflowInstanceWorkflowsEmpty rScope win + EExamListR -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam + E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId + E.||. E.exists (E.from $ \externalExamResult -> + E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId + E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId + ) + guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do + -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return Authorized + r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index fda1576d6..497d52a00 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -56,6 +56,8 @@ workflowInstanceInitiateR rScope win = do } return . Just $ do + memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId)) + addMessageI Success MsgWorkflowInstanceInitiateSuccess cID <- encrypt wwId diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index d5be3e0c9..517b2c150 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -91,12 +91,19 @@ workflowR rScope cID = do edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState - memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) - memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + wInstance <- for workflowWorkflowInstance $ \wiId -> do + wInstance@WorkflowInstance{..} <- get404 wiId + wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope + return (wiScope, Entity wiId wInstance) update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ] return . Just $ do + whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> + memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId)) + memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess redirect canonRoute