perf: additional/improved auth caching

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)

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
+      case route of
+        CSubmissionR _ _ _ _ cID _ -> lift . $cachedHereBinary (authId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
+          sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+          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 _ -> 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
-        return (course E.^. CourseId, sheet E.^. SheetId)
+            E.where_ $ course E.^. CourseTerm E.==. E.val tid
-      let
+                 E.&&. course E.^. CourseSchool E.==. E.val ssh
-        resMap :: Map CourseId (Set SheetId)
+                 E.&&. course E.^. CourseShorthand E.==. E.val csh
-        resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
+                 E.&&. sheet E.^. SheetName E.==. E.val shn
-      case route of
-        CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
-          sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
-          Submission{..} <- MaybeT . lift $ get sid
-          guard $ Just authId == submissionRatingBy
           return Authorized
-        CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ 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
-          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
           return Authorized
-        CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
+        _ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do
-          Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+          guardM . lift . E.selectExists . E.from $ \sheetCorrector ->
-          guard $ cid `Set.member` Map.keysSet resMap
+            E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
-          return Authorized
-        _ -> do
-          guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
           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,23 +1450,45 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route
         guard $ not hasOther
         return Authorized
   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
+  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 E.^. WorkflowWorkflowId
+                return workflowWorkflow
-                        , workflowWorkflow E.^. WorkflowWorkflowScope
+              workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
-                        )
+                wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
-               checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do
+                let
-                 cID <- encrypt wwId
+                  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
-                 guardM . lift . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
+            cID <- encrypt wwId
-                 return True
+            let route' = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
-           guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
+            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

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

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))
+        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 ]
 
         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