fix(cache): atomicity & workflow instance invalidations

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

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

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

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 )

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
+  -- This was not implemented in the hopes that atomicModifyIORef'
-  -- likely associated with the atomic transaction required for the
+  -- already offers sufficient performance.
-  -- "compare and swap"
+  --
+  -- 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.