fix: invalidate nav caches

src/Foundation.hs

@@ -10,5 +10,5 @@ import Foundation.Instances as Foundation (ButtonClass(..), unsafeHandler)
 import Foundation.Authorization as Foundation
 import Foundation.SiteLayout as Foundation
 import Foundation.DB as Foundation
-import Foundation.Navigation as Foundation (evalAccessCorrector)
+import Foundation.Navigation as Foundation (evalAccessCorrector, NavigationCacheKey(..))
 import Foundation.Yesod.Middleware as Foundation (updateFavourites)

src/Foundation/Authorization.hs

@@ -404,7 +404,7 @@ data AuthorizationCacheKey
   | AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
   | AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving anyclass (Binary)
+  deriving anyclass (Hashable, Binary)
 
 cacheAPSchoolFunction :: BearerAuthSite UniWorX
                       => SchoolFunction

src/Foundation/Navigation.hs

@@ -7,6 +7,7 @@ module Foundation.Navigation
   ( NavQuickView(..), NavType(..), NavLevel(..), NavHeaderRole(..), NavLink(..), Nav(..), NavChildren
   , _navModal, _navMethod, _navData, _navLabel, _navType, _navForceActive, _navHeaderRole, _navIcon, _navLink, _navChildren
   , _NavHeader, _NavHeaderContainer, _NavPageActionPrimary, _NavPageActionSecondary, _NavFooter
+  , NavigationCacheKey(..)
   , navBaseRoute, navLinkRoute
   , pageActions
   , pageQuickActions
@@ -41,6 +42,11 @@ import qualified Data.Conduit.Combinators as C
 import Utils.Workflow
 import Handler.Utils.Workflow.CanonicalRoute
 
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+import Data.List (inits)
+
 
 -- Define breadcrumbs.
 i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
@@ -432,7 +438,7 @@ data NavType
     , navData   :: [(Text, Text)]
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving anyclass (Binary)
+  deriving anyclass (Hashable, Binary)
 
 makeLenses_ ''NavType
 makePrisms ''NavType
@@ -501,6 +507,21 @@ type family ChildrenNavChildren a where
 
   ChildrenNavChildren a = Children ChGeneric a
 
+data NavigationCacheKey
+  = NavCacheRouteAccess AuthContext NavType (Route UniWorX)
+  | NavCacheHaveWorkflowWorkflowsRoles RouteWorkflowScope
+  | NavCacheHaveTopWorkflowInstancesRoles | NavCacheHaveTopWorkflowWorkflowsRoles
+  | NavCacheHaveTopWorkflowsInstances AuthContext
+  deriving (Generic, Typeable)
+
+deriving stock instance Eq (AuthId UniWorX) => Eq NavigationCacheKey
+deriving stock instance Ord (AuthId UniWorX) => Ord NavigationCacheKey
+deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read NavigationCacheKey
+deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show NavigationCacheKey
+deriving anyclass instance Hashable (AuthId UniWorX) => Hashable NavigationCacheKey
+deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey
+
+
 navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX, MonadUnliftIO m) => Nav -> MaybeT m Nav
 navAccess = execStateT $ do
   guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess
@@ -518,7 +539,7 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
     accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
     accessCheck nt (urlRoute -> route) = do
       authCtx <- getAuthContext
-      $memcachedByHere (Just . Right $ 2 * diffMinute) (authCtx, nt, route) $
+      memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) $
         bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
   
 defaultLinks :: ( MonadHandler m
@@ -709,7 +730,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
       }
   , do
       authCtx <- getAuthContext
-      (haveInstances, haveWorkflows) <- $memcachedByHere (Just $ Right diffDay) authCtx . liftHandler . runDBRead $ (,) -- We don't expect haveTopWorkflowWorkflows to be relevant and haveTopWorkflowInstances shouldn't change often
+      (haveInstances, haveWorkflows) <- memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . liftHandler . runDBRead $ (,)
         <$> haveTopWorkflowInstances
         <*> haveTopWorkflowWorkflows
 
@@ -2596,34 +2617,48 @@ evalAccessCorrector
 evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
 
   
-_haveWorkflowInstances, haveWorkflowWorkflows
+haveWorkflowWorkflows
   :: ( MonadHandler m, HandlerSite m ~ UniWorX
      , BackendCompatible SqlReadBackend backend
      , BearerAuthSite UniWorX
      )
   => RouteWorkflowScope
   -> ReaderT backend m Bool
-_haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
+haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHereBinary rScope . maybeT (return False) $ do
-  scope <- fromRouteWorkflowScope rScope
+  roles <- memcachedBy (Just $ Right diffDay) (NavCacheHaveWorkflowWorkflowsRoles rScope) $ do
+    scope <- fromRouteWorkflowScope rScope
 
-  let checkAccess (Entity _ WorkflowInstance{..})
+    let
-        = lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
-      getInstances = E.selectSource . E.from $ \workflowInstance -> do
-        E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
-        return workflowInstance
-
-  $cachedHereBinary scope . runConduit $ transPipe lift getInstances .| C.mapM checkAccess .| C.or
-haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
-  scope <- fromRouteWorkflowScope rScope
-
-  let checkAccess (E.Value wwId) = do
-        cID <- lift . lift $ encrypt wwId
-        lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
       getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
         E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
-        return $ workflowWorkflow E.^. WorkflowWorkflowId
+        return workflowWorkflow
+      workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
+        wwGraph <- lift $ 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)
 
-  $cachedHereBinary scope . runConduit $ transPipe lift getWorkflows .| C.mapM checkAccess .| C.or
+        cID <- encrypt wwId
+        return . Set.mapMonotonic ((wwId, cID), ) $ fold nodeViewers <> fold payloadViewers
+
+    runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles
+
+  let
+    evalRole ((wwId, cID), role) = do
+      let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+      is _Authorized <$> hasWorkflowRole (Just wwId) role route False
+
+  lift $ anyM roles evalRole
 
 haveTopWorkflowInstances, haveTopWorkflowWorkflows
   :: ( MonadHandler m, HandlerSite m ~ UniWorX
@@ -2631,18 +2666,57 @@ haveTopWorkflowInstances, haveTopWorkflowWorkflows
      , BearerAuthSite UniWorX
      )
   => ReaderT backend m Bool
-haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
+haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do
-  let checkAccess (Entity _ WorkflowInstance{..}) = do
+  roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowInstancesRoles $ do
+    let
+      getInstances = E.selectSource . E.from $ \workflowInstance -> do
+        E.where_ . isTopWorkflowScopeSql $ workflowInstance E.^. WorkflowInstanceScope
+        return workflowInstance
+      instanceRoles (Entity _ WorkflowInstance{..}) = do
         rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
-        lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
+        wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
-      getInstances = selectSource [] []
+        return . Set.mapMonotonic ((rScope, workflowInstanceName), ) . fold $ do
-      isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope
+          WGN{..} <- wiGraph ^.. _wgNodes . folded
-   in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or
+          WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
-haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
+          return wgeActors
-  let checkAccess (Entity wwId WorkflowWorkflow{..}) = do
+    runConduit $ transPipe lift getInstances .| C.foldMapM instanceRoles
+
+  let
+    evalRole ((rScope, win), role) = do
+      let route = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
+      is _Authorized <$> hasWorkflowRole Nothing role route False
+
+  lift $ anyM roles evalRole
+haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do
+  roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowWorkflowsRoles $ do
+    let
+      getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
+        E.where_ . isTopWorkflowScopeSql $ workflowWorkflow E.^. WorkflowWorkflowScope
+        return workflowWorkflow
+      workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
+        wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
         rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
-        cID <- lift . lift $ encrypt wwId
+        let
-        lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+          nodeViewers = do
-      getWorkflows = selectSource [] []
+            WorkflowAction{..} <- otoList workflowWorkflowState
-      isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope
+            (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
-   in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or
+            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)
+
+        cID <- encrypt wwId
+        return . Set.mapMonotonic ((wwId, cID, rScope), ) $ fold nodeViewers <> fold payloadViewers
+    runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles
+
+  let
+    evalRole ((wwId, cID, rScope), role) = do
+      let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+      is _Authorized <$> hasWorkflowRole (Just wwId) role route False
+
+  lift $ anyM roles evalRole

src/Handler/Workflow/Instance/Initiate.hs

@@ -57,6 +57,10 @@ workflowInstanceInitiateR rScope win = do
 
       return . Just $ do
         memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
+        memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles rScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
+        when (isTopWorkflowScope rScope) $
+          memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
+
         
         addMessageI Success MsgWorkflowInstanceInitiateSuccess
 

src/Handler/Workflow/Workflow/Workflow.hs

@@ -99,8 +99,11 @@ workflowR rScope cID = do
         update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
 
         return . Just $ do
-          whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) ->
+          whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do
             memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
+            memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles wiScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
+            when (isTopWorkflowScope wiScope) $
+              memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
           memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
           memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
 

src/Model/Types/Workflow.hs

@@ -343,6 +343,7 @@ data WorkflowScope termid schoolid courseid
   | WSTermSchool { wisTerm :: termid, wisSchool :: schoolid }
   | WSCourse { wisCourse :: courseid }
   deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
+  deriving anyclass (Hashable)
 
 data WorkflowScope'
   = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'

src/Network/HTTP/Types/Method/Instances.hs

@@ -14,8 +14,9 @@ import Utils.PathPiece (pathPieceJSON, pathPieceJSONKey)
 import Web.PathPieces
 
 
-deriving instance Generic StdMethod
+deriving stock instance Generic StdMethod
-instance Binary StdMethod
+deriving anyclass instance Binary StdMethod
+deriving anyclass instance Hashable StdMethod
 
 instance PathPiece Method where
   toPathPiece = decodeUtf8