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

fix: invalidate nav caches

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-12 18:39:00 +01:00
parent 364bf527aa
commit e88b6d6bab
7 changed files with 122 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Foundation.hs
View File

@ -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)

2
src/Foundation/Authorization.hs
View File

@ -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

142
src/Foundation/Navigation.hs
View File

@ -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

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

@ -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

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

@ -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))

1
src/Model/Types/Workflow.hs
View File

@ -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'

5
src/Network/HTTP/Types/Method/Instances.hs
View File

@ -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