diff --git a/src/Foundation.hs b/src/Foundation.hs index 6a9988f6c..66c4cd7c3 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index bb2f35ad2..6b16505a2 100644 --- a/src/Foundation/Authorization.hs +++ b/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 69f6d2121..506bbf8c5 100644 --- a/src/Foundation/Navigation.hs +++ b/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 - scope <- fromRouteWorkflowScope rScope +haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHereBinary rScope . maybeT (return False) $ do + roles <- memcachedBy (Just $ Right diffDay) (NavCacheHaveWorkflowWorkflowsRoles rScope) $ do + scope <- fromRouteWorkflowScope rScope - let checkAccess (Entity _ WorkflowInstance{..}) - = 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) + let 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) $ - let checkAccess (Entity _ WorkflowInstance{..}) = do +haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ 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) - getInstances = selectSource [] [] - isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope - in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or -haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ - let checkAccess (Entity wwId WorkflowWorkflow{..}) = do + wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph + return . Set.mapMonotonic ((rScope, workflowInstanceName), ) . fold $ do + WGN{..} <- wiGraph ^.. _wgNodes . folded + WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded + return wgeActors + 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 - lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) - getWorkflows = selectSource [] [] - isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope - in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or + 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) + + 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 diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index 497d52a00..361d675c5 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/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 diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 517b2c150..f185340c8 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/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)) diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 97cee5966..2d7a7a496 100644 --- a/src/Model/Types/Workflow.hs +++ b/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' diff --git a/src/Network/HTTP/Types/Method/Instances.hs b/src/Network/HTTP/Types/Method/Instances.hs index b71b009ea..bf3931a69 100644 --- a/src/Network/HTTP/Types/Method/Instances.hs +++ b/src/Network/HTTP/Types/Method/Instances.hs @@ -14,8 +14,9 @@ import Utils.PathPiece (pathPieceJSON, pathPieceJSONKey) import Web.PathPieces -deriving instance Generic StdMethod -instance Binary StdMethod +deriving stock instance Generic StdMethod +deriving anyclass instance Binary StdMethod +deriving anyclass instance Hashable StdMethod instance PathPiece Method where toPathPiece = decodeUtf8