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

perf: additional/improved auth caching

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-12 14:59:38 +01:00
parent 26b94a2290
commit 6fbef0433c
4 changed files with 106 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Database/Persist/Sql/Types/Instances.hs
View File

@ -8,6 +8,8 @@ import ClassyPrelude
import Database.Persist.Sql import Database.Persist.Sql
import Data.Binary (Binary)
instance BackendCompatible SqlWriteBackend SqlWriteBackend where instance BackendCompatible SqlWriteBackend SqlWriteBackend where
projectBackend = id projectBackend = id
@ -20,3 +22,5 @@ instance BackendCompatible SqlReadBackend SqlBackend where
instance BackendCompatible SqlWriteBackend SqlBackend where instance BackendCompatible SqlWriteBackend SqlBackend where
projectBackend = SqlWriteBackend projectBackend = SqlWriteBackend
deriving newtype instance Binary (BackendKey SqlBackend)

155
src/Foundation/Authorization.hs
View File

@ -399,6 +399,7 @@ data AuthorizationCacheKey
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope | AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope
| AuthCacheWorkflowInstanceWorkflowViewers 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
@ -672,7 +673,7 @@ tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerL
, runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser) , runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
) )
tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if 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 _ | is _Nothing mAuthId' -> return AuthenticationRequired
CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector
CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector
@ -680,31 +681,35 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo
_other -> unauthorizedI MsgUnauthorizedCorrectorAny _other -> unauthorizedI MsgUnauthorizedCorrectorAny
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId 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 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 sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid guardM . lift . E.selectExists . E.from $ \submission ->
guard $ Just authId == submissionRatingBy E.where_ $ submission E.^. SubmissionId E.==. E.val sid
E.&&. submission E.^. SubmissionRatingBy E.==. E.justVal authId
return Authorized return Authorized
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do CSheetR tid ssh csh shn _ -> lift . $cachedHereBinary (authId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) 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 return Authorized
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do CourseR tid ssh csh _ -> lift . $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
guard $ cid `Set.member` Map.keysSet resMap 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 return Authorized
_ -> do _ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) guardM . lift . E.selectExists . E.from $ \sheetCorrector ->
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
return Authorized return Authorized
where where
mkCorrectorList = runDBRead . execWriterT $ do mkCorrectorList = runDBRead . execWriterT $ do
@ -713,7 +718,7 @@ tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCo
return $ submission E.^. SubmissionRatingBy return $ submission E.^. SubmissionRatingBy
tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser) tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser)
tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if 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 _ | is _Nothing mAuthId' -> return AuthenticationRequired
CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector
CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector
@ -746,7 +751,7 @@ tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCac
where where
mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser) 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 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 _ | is _Nothing mAuthId' -> return AuthenticationRequired
CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor
CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor
@ -1445,47 +1450,69 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route
guard $ not hasOther guard $ not hasOther
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRegisterGroup r r -> $unsupportedAuthPredicate AuthRegisterGroup r
tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do
-> let workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do mr <- getMsgRenderer
scope <- fromRouteWorkflowScope rScope let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
let dbScope = scope ^. _DBWorkflowScope orAR' = shortCircuitM (is _Authorized) (orAR mr)
getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do _andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win workflowInstanceWorkflowsEmpty rScope win = selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do
return ( workflowWorkflow E.^. WorkflowWorkflowId scope <- fromRouteWorkflowScope rScope
, workflowWorkflow E.^. WorkflowWorkflowScope let dbScope = scope ^. _DBWorkflowScope
) getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
cID <- encrypt wwId E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope
guardM . lift . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) return workflowWorkflow
return True workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
return AuthorizedI18n let
in case route of nodeViewers = do
r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute WorkflowAction{..} <- otoList workflowWorkflowState
-> workflowInstanceWorkflowsEmpty rScope win (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
EExamListR -> exceptT return return $ do guard $ node == wpTo
authId <- maybeExceptT AuthenticationRequired $ return mAuthId WorkflowNodeView{..} <- hoistMaybe wgnViewers
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do return $ toNullable wnvViewers
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam payloadViewers = do
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId (prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
E.||. E.exists (E.from $ \externalExamResult -> prevAct <- hoistMaybe $ prevActs ^? _last
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId payload <- Map.keys $ wpPayload act
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId 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)
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty return . Set.mapMonotonic ((workflowWorkflowScope, wwId), ) $ fold nodeViewers <> fold payloadViewers
return Authorized lift . runConduit $ getWorkflowWorkflows .| C.foldMapM workflowRoles
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do let
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh evalRole ((wwScope, wwId), role) = do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] cID <- encrypt wwId
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do let route' = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route' False
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
return Authorized return AuthorizedI18n
r -> $unsupportedAuthPredicate AuthEmpty r 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 tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh

2
src/Handler/Workflow/Instance/Initiate.hs
View File

@ -56,6 +56,8 @@ workflowInstanceInitiateR rScope win = do
} }
return . Just $ do return . Just $ do
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
addMessageI Success MsgWorkflowInstanceInitiateSuccess addMessageI Success MsgWorkflowInstanceInitiateSuccess
cID <- encrypt wwId cID <- encrypt wwId

11
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -91,12 +91,19 @@ workflowR rScope cID = do
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) wInstance <- for workflowWorkflowInstance $ \wiId -> do
memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) wInstance@WorkflowInstance{..} <- get404 wiId
wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
return (wiScope, Entity wiId wInstance)
update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ] update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
return . Just $ do 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 addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess
redirect canonRoute redirect canonRoute