diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 5d3f9a697..cef8e26ea 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1720,7 +1720,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write) - roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do + roles <- memcacheAuth' @(Set (WorkflowRole UserId)) (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph @@ -1753,7 +1753,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges) return Authorized | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do - (wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do + (wwId, roles) <- memcacheAuth' @(WorkflowWorkflowId, Set (WorkflowRole UserId)) (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph @@ -1772,7 +1772,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> 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 (wwId, fold nodeViewers <> fold payloadViewers :: (Set (WorkflowRole UserId))) + return (wwId, fold nodeViewers <> fold payloadViewers) let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 05495331a..3f2f77b37 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -2734,7 +2734,7 @@ haveTopWorkflowInstances, haveTopWorkflowWorkflows ) => ReaderT backend m Bool haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do - roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowInstancesRoles $ do + roles <- memcachedBy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId)) (Just $ Right diffDay) NavCacheHaveTopWorkflowInstancesRoles $ do let getInstances = E.selectSource . E.from $ \workflowInstance -> do E.where_ . isTopWorkflowScopeSql $ workflowInstance E.^. WorkflowInstanceScope diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs index 41dd2aecc..937a26d32 100644 --- a/src/Handler/Utils/Memcached.hs +++ b/src/Handler/Utils/Memcached.hs @@ -356,7 +356,8 @@ memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX => Maybe Expiry -> m a -> m a memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x) -memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX +memcachedBy :: forall a m k. + ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , Typeable a, Binary a, NFData a , Binary k @@ -550,7 +551,7 @@ memcacheAuth k mx = cachedByBinary k $ do | otherwise -> evalWriterT mx -memcacheAuth' :: forall m k a. +memcacheAuth' :: forall a m k. ( MonadHandler m, HandlerSite m ~ UniWorX , MonadThrow m , Typeable a, Binary a, NFData a diff --git a/src/Handler/Workflow/Instance/Update.hs b/src/Handler/Workflow/Instance/Update.hs index ebd018209..5453fba79 100644 --- a/src/Handler/Workflow/Instance/Update.hs +++ b/src/Handler/Workflow/Instance/Update.hs @@ -15,6 +15,8 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map.Strict as Map +import Handler.Utils.Memcached + data WorkflowInstanceUpdateButton = BtnWorkflowInstanceUpdate @@ -113,5 +115,9 @@ updateR rScope win = do , WorkflowInstanceDescriptionDescription =. mDesc ] addMessageI Success $ MsgWorkflowInstanceUpdateUpdatedDescriptionLanguage lang + memcachedByInvalidate (AuthCacheWorkflowInstanceInitiators win rScope) $ Proxy @(Set (WorkflowRole UserId)) + memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId)) + when (isTopWorkflowScope rScope) $ + memcachedByInvalidate NavCacheHaveTopWorkflowInstancesRoles $ Proxy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId)) redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR ) diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs index 1545ebf08..62726eb62 100644 --- a/src/Utils/ARC.hs +++ b/src/Utils/ARC.hs @@ -277,20 +277,25 @@ cachedARC' :: forall k w v m. cachedARC' (ARCHandle arcVar) k f = do oldVal <- lookupARC k <$> readIORef arcVar newVal <- f oldVal - modifyIORef' arcVar $ uncurry (insertARC k newVal) + atomicModifyIORef' arcVar $ (, ()) . uncurry (insertARC k newVal) -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very -- well drop newer values computed during the update. -- - -- Currently we accept that to reduce lock contention. + -- This was deemed unacceptable due to the risk of cache + -- invalidations being silently dropped -- -- Another alternative would be to use "optimistic locking", -- i.e. read the current value of `arcVar`, compute an updated -- version, and write it back atomically iff the `ARCTick` hasn't -- changed. -- - -- This was not implemented to avoid the overhead and contention - -- likely associated with the atomic transaction required for the - -- "compare and swap" + -- This was not implemented in the hopes that atomicModifyIORef' + -- already offers sufficient performance. + -- + -- If optimistic locking is implemented there is a risk of + -- performance issues due to the overhead and contention likely + -- associated with the atomic transaction required for the "compare + -- and swap" return $ view _1 <$> newVal cachedARC :: forall k w v m.