perf: additional/improved auth caching
This commit is contained in:
Gregor Kleen
parent
26b94a2290
commit
6fbef0433c
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user