refactor(workflows): shared workflow graphs

models/workflows.model

@@ -1,5 +1,10 @@
-WorkflowDefinition
+SharedWorkflowGraph
+    hash        WorkflowGraphReference
     graph       (WorkflowGraph FileReference SqlBackendKey) -- UserId
+    Primary     hash
+
+WorkflowDefinition
+    graph       SharedWorkflowGraphId
     scope       WorkflowScope'
     name        WorkflowDefinitionName 
     instanceCategory WorkflowInstanceCategory Maybe
@@ -21,7 +26,7 @@ WorkflowDefinitionInstanceDescription
 
 WorkflowInstance
     definition  WorkflowDefinitionId Maybe
-    graph       (WorkflowGraph FileReference SqlBackendKey)  -- UserId
+    graph       SharedWorkflowGraphId
     scope       (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)  -- TermId, SchoolId, CourseId
     name        WorkflowInstanceName
     category    WorkflowInstanceCategory Maybe
@@ -37,5 +42,5 @@ WorkflowInstanceDescription
 WorkflowWorkflow
     instance    WorkflowInstanceId Maybe
     scope       (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)  -- TermId, SchoolId, CourseId
-    graph       (WorkflowGraph FileReference SqlBackendKey)  -- UserId
+    graph       SharedWorkflowGraphId
     state       (WorkflowState FileReference SqlBackendKey)  -- UserId

src/Foundation/Authorization.hs

@@ -1416,9 +1416,8 @@ 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)
         scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
         Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
+        wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
         let
-          wiGraph :: IdWorkflowGraph
-          wiGraph = _DBWorkflowGraph # workflowInstanceGraph
           edges = do
             WGN{..} <- wiGraph ^.. _wgNodes . folded
             WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
@@ -1434,11 +1433,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
             (wwId, edges) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowEdgeActors cID) $ do
               wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
               WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
+              wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
 
               let
-                wwGraph :: IdWorkflowGraph
-                wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
-
                 wwNode = wpTo $ last workflowWorkflowState
 
               return . (wwId, ) . (Set.fromList :: _ -> Set (WorkflowRole UserId)) . foldMap toNullable $ do
@@ -1455,11 +1452,9 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
             (wwId, roles) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
               wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
               WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
+              wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
 
               let
-                wwGraph :: IdWorkflowGraph
-                wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
-
                 nodeViewers = do
                   WorkflowAction{..} <- otoList workflowWorkflowState
                   (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
@@ -1483,9 +1478,7 @@ tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite ->
         wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
         WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
         stIx <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decryptWorkflowStateIndex wwId stCID
-        let
+        wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
-          wwGraph :: IdWorkflowGraph
-          wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
         act <- workflowStateIndex stIx $ _DBWorkflowState # workflowWorkflowState 
         let
           cState = wpTo act
@@ -1767,8 +1760,8 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
   WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
   rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
   cID <- hoist lift . catchMaybeT (Proxy @CryptoIDError) . lift $ encrypt wwId
-  let WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
+  WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
-      canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+  let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
       evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False
   WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
   guardM $ orM

src/Foundation/Yesod/Middleware.hs

@@ -313,7 +313,8 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
       (_, WorkflowWorkflowR cID (WWFilesR wpl _)) <- hoistMaybe $ route ^? _WorkflowScopeRoute
       wwId <- decrypt cID
       WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId . lift $ get wwId
-      [wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes workflowWorkflowGraph
+      wwGraph <- lift . lift $ getSharedDBWorkflowGraph workflowWorkflowGraph
+      [wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes wwGraph
       (caseChanged `on` unWorkflowPayloadLabel) wpl wpl'
       return $ route
         & typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl'

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -81,14 +81,15 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
   MsgRenderer mr <- getMsgRenderer
 
   ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
-  let (scope, graph) = case ctx of
+  let (scope, sharedGraphId) = case ctx' of
-        Left  WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope
+        Left  (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
-                                      , _DBWorkflowGraph # workflowInstanceGraph
+                                                 , workflowInstanceGraph
-                                      )
+                                                 )
-        Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope
+        Right (Entity _ WorkflowWorkflow{..}) -> ( _DBWorkflowScope # workflowWorkflowScope
-                                      , _DBWorkflowGraph # workflowWorkflowGraph
+                                                 , workflowWorkflowGraph
-                                      )
+                                                 )
-      wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
+  graph <- lift $ getSharedIdWorkflowGraph sharedGraphId
+  let wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
       wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState 
       ctx = bimap entityVal entityVal ctx'
   mAuthId <- maybeAuthId

src/Handler/Workflow/Definition/Edit.hs

@@ -5,6 +5,7 @@ module Handler.Workflow.Definition.Edit
   ) where
 
 import Import
+import Utils.Workflow
 import Handler.Utils
 import Handler.Workflow.Definition.Form
 
@@ -29,7 +30,7 @@ postAWDEditR wds' wdn = do
             | Entity _ WorkflowDefinitionInstanceDescription{..} <- iDescs
             ]
 
-      wdfGraph <- toWorkflowGraphForm workflowDefinitionGraph
+      wdfGraph <- toWorkflowGraphForm =<< getSharedDBWorkflowGraph workflowDefinitionGraph
 
       return WorkflowDefinitionForm
         { wdfScope = workflowDefinitionScope
@@ -44,9 +45,10 @@ postAWDEditR wds' wdn = do
 
     act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
       wdfGraph' <- fromWorkflowGraphForm wdfGraph
+      wdfGraph'' <- insertSharedWorkflowGraph wdfGraph'
       
       insConflict <- replaceUnique wdId WorkflowDefinition
-        { workflowDefinitionGraph = wdfGraph'
+        { workflowDefinitionGraph = wdfGraph''
         , workflowDefinitionScope = wdfScope
         , workflowDefinitionName = wdfName
         , workflowDefinitionInstanceCategory = wdfInstanceCategory

src/Handler/Workflow/Definition/Instantiate.hs

@@ -3,6 +3,7 @@ module Handler.Workflow.Definition.Instantiate
   ) where
 
 import Import
+import Utils.Workflow
 import Handler.Utils
 import Handler.Utils.Workflow.Form
 
@@ -22,9 +23,10 @@ postAWDInstantiateR wds' wdn = do
             & over _wisTerm   unTermKey
             & over _wisSchool unSchoolKey
             & over _wisCourse (view _SqlKey)
+      workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
       instId <- insertUnique WorkflowInstance
         { workflowInstanceDefinition = Just wdId
-        , workflowInstanceGraph = wifGraph'
+        , workflowInstanceGraph
         , workflowInstanceScope = wifScope'
         , workflowInstanceName = wifName
         , workflowInstanceCategory = wifCategory

src/Handler/Workflow/Definition/New.hs

@@ -5,6 +5,7 @@ module Handler.Workflow.Definition.New
 import Import
 import Handler.Utils
 import Handler.Workflow.Definition.Form
+import Utils.Workflow
 
 
 getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html
@@ -15,9 +16,10 @@ postAdminWorkflowDefinitionNewR = do
 
     act <- formResultMaybe newRes $ \WorkflowDefinitionForm{ .. } -> do
       wdfGraph' <- fromWorkflowGraphForm wdfGraph
+      workflowDefinitionGraph <- insertSharedWorkflowGraph wdfGraph'
       
       insRes <- insertUnique WorkflowDefinition
-        { workflowDefinitionGraph = wdfGraph'
+        { workflowDefinitionGraph
         , workflowDefinitionScope = wdfScope
         , workflowDefinitionName = wdfName
         , workflowDefinitionInstanceCategory = wdfInstanceCategory

src/Handler/Workflow/Instance/Form.hs

@@ -64,7 +64,7 @@ workflowInstanceForm forcedDefId template = renderWForm FormStandard $ do
       [ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
       | Entity _ WorkflowDefinitionInstanceDescription{..} <- descs
       ]
-  defGraph <- for defEnt $ toWorkflowGraphForm . workflowDefinitionGraph . entityVal
+  defGraph <- for defEnt $ toWorkflowGraphForm <=< lift . lift . getSharedDBWorkflowGraph . workflowDefinitionGraph . entityVal
 
   wifScopeRes <- aFormToWForm . hoistAForm lift $ workflowInstanceScopeForm (workflowDefinitionScope . entityVal <$> defEnt) (fslI MsgWorkflowScope) (wifScope <$> template)
   wifNameRes <- wreq ciField (fslI MsgWorkflowInstanceName) (fmap wifName template <|> fmap (workflowDefinitionName . entityVal) defEnt)

src/Handler/Workflow/Instance/Initiate.hs

@@ -45,7 +45,8 @@ workflowInstanceInitiateR rScope win = do
     ((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
 
     edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
-      workflowWorkflowState <- view _DBWorkflowState <$> followEdge (_DBWorkflowGraph # workflowInstanceGraph) edgeRes' Nothing
+      wGraph <- getSharedIdWorkflowGraph workflowInstanceGraph
+      workflowWorkflowState <- view _DBWorkflowState <$> followEdge wGraph edgeRes' Nothing
       
       wwId <- insert WorkflowWorkflow
         { workflowWorkflowInstance = Just wiId

src/Handler/Workflow/Instance/New.hs

@@ -25,13 +25,14 @@ adminWorkflowInstanceNewR wdId = do
 
     act <- formResultMaybe instRes $ \WorkflowInstanceForm{..} -> do
       wifGraph' <- fromWorkflowGraphForm wifGraph
+      workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
       let wifScope' = wifScope
             & over _wisTerm   unTermKey
             & over _wisSchool unSchoolKey
             & over _wisCourse (view _SqlKey)
       instId <- insertUnique WorkflowInstance
         { workflowInstanceDefinition = wdId
-        , workflowInstanceGraph = wifGraph'
+        , workflowInstanceGraph
         , workflowInstanceScope = wifScope'
         , workflowInstanceName = wifName
         , workflowInstanceCategory = wifCategory

src/Handler/Workflow/Workflow/List.hs

@@ -231,8 +231,8 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
               MaybeT $ selectWorkflowInstanceDescription wiId
             cID <- encrypt wwId
             rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
-            let WorkflowGraph{..} = ww ^. _entityVal . _workflowWorkflowGraph . from _DBWorkflowGraph
+            WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
-                hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
+            let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
                 hasWorkflowRole' role = maybeT (return False) $ do
                   rScope' <- hoistMaybe rScope
                   let canonRoute = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
@@ -360,6 +360,8 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
                 jwiScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
                 let jwiName = workflowInstanceName
                 return JsonWorkflowInstance{..}
+              let Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
+              WorkflowGraph{..} <- getSharedIdWorkflowGraph workflowWorkflowGraph
               (fmap getLast -> wState) <-
                 let go :: forall m.
                           ( MonadHandler m
@@ -410,9 +412,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
 
                       tell . Just $ Last (stCID, nTo, aUser, wpTime, payload)
 
-                    Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
                     wState = review _DBWorkflowState workflowWorkflowState
-                    WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
                  in runConduit $ sourceWorkflowActionInfos wwId wState .| execWriterC (C.mapM_ go)
 
               let jwwLastAction = wState <&> \(jwaIx, jwaTo, jwaUser, jwaTime, _) -> JsonWorkflowAction{..}

src/Handler/Workflow/Workflow/Workflow.hs

@@ -83,8 +83,8 @@ workflowR rScope cID = do
     WorkflowWorkflow{..} <- get404 wwId
     maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
     mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
+    wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
     let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-        wGraph = _DBWorkflowGraph # workflowWorkflowGraph
 
     mEdge <- for mEdgeForm $ \edgeForm -> do
       ((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm

src/Jobs.hs

@@ -290,7 +290,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
 
       return $ $logWarnS "JobPoolManager" [st|Moved #{tshow (olength movePairs)} long-unadressed jobs from #{tshow (olength senders)} senders to #{tshow (olength receivers)} receivers|]
 
-    manageOffloadHandler :: (ReaderT UniWorX m JobOffloadHandler) -> STM (ContT () m ())
+    manageOffloadHandler :: ReaderT UniWorX m JobOffloadHandler -> STM (ContT () m ())
     manageOffloadHandler spawn = do
       shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
       guard $ not shouldTerminate'

src/Jobs/Handler/Files.hs

@@ -73,9 +73,7 @@ fileReferences (E.just -> fHash)
     ]
 
 workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (SqlPersistT m) ()
-workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. WorkflowDefinitionGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
+workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
-                                 , E.selectSource (E.from $ pure . (E.^. WorkflowInstanceGraph  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
-                                 , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowGraph  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
                                  , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
                                  ]
 

src/Jobs/Offload.hs

@@ -47,7 +47,7 @@ mkJobOffloadHandler dbConf jMode
           let
             getInput = do
               n@PG.Notification{..} <- liftIO $ PG.getNotification pgConn
-              if | notificationPid == myPid || notificationChannel /= (encodeUtf8 jobOffloadChannel) -> getInput
+              if | notificationPid == myPid || notificationChannel /= encodeUtf8 jobOffloadChannel -> getInput
                  | otherwise -> return n
             getOutput = atomically $ do
               jQueue <- readTVar jobOffloadOutgoing

src/Model/Migration/Definitions.hs

@@ -47,6 +47,8 @@ import Data.Time.Format
 
 import qualified Data.Time.Zones as TZ
 
+import Utils.Workflow
+
 
 data ManualMigration
   = Migration20180813SimplifyUserTheme
@@ -97,6 +99,7 @@ data ManualMigration
   | Migration20201106StoredMarkup
   | Migration20201119RoomTypes
   | Migration20210115ExamPartsFrom
+  | Migration20210201SharedWorkflowGraphs
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
@@ -968,6 +971,55 @@ customMigrations = mapF $ \case
           migrateExam _ = return ()
        in runConduit $ getExam .| C.mapM_ migrateExam
 
+  Migration20210201SharedWorkflowGraphs -> do
+    unlessM (tableExists "shared_workflow_graph")
+      [executeQQ|CREATE TABLE "shared_workflow_graph" ("hash" bytea primary key, "graph" jsonb not null)|]
+
+    whenM (tableExists "workflow_definition") $ do
+      [executeQQ|ALTER TABLE "workflow_definition" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
+      let getDefinitions = [queryQQ|SELECT "id", "graph" FROM "workflow_definition"|]
+          migrateDefinition [ fromPersistValue -> Right (wdId :: WorkflowDefinitionId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
+            swgId <- insertSharedWorkflowGraph graph
+            [executeQQ|UPDATE "workflow_definition" SET "graph_id" = #{swgId} WHERE "id" = #{wdId}|]
+          migrateDefinition _ = return ()
+       in runConduit $ getDefinitions .| C.mapM_ migrateDefinition
+
+      [executeQQ|
+        ALTER TABLE "workflow_definition" DROP COLUMN "graph";
+        ALTER TABLE "workflow_definition" ALTER COLUMN "graph_id" SET not null;
+        ALTER TABLE "workflow_definition" RENAME COLUMN "graph_id" TO "graph";
+      |]
+
+    whenM (tableExists "workflow_instance") $ do
+      [executeQQ|ALTER TABLE "workflow_instance" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
+      let getInstances = [queryQQ|SELECT "id", "graph" FROM "workflow_instance"|]
+          migrateInstance [ fromPersistValue -> Right (wiId :: WorkflowInstanceId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
+            swgId <- insertSharedWorkflowGraph graph
+            [executeQQ|UPDATE "workflow_instance" SET "graph_id" = #{swgId} WHERE "id" = #{wiId}|]
+          migrateInstance _ = return ()
+       in runConduit $ getInstances .| C.mapM_ migrateInstance
+
+      [executeQQ|
+        ALTER TABLE "workflow_instance" DROP COLUMN "graph";
+        ALTER TABLE "workflow_instance" ALTER COLUMN "graph_id" SET not null;
+        ALTER TABLE "workflow_instance" RENAME COLUMN "graph_id" TO "graph";
+      |]
+
+    whenM (tableExists "workflow_workflow") $ do
+      [executeQQ|ALTER TABLE "workflow_workflow" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
+      let getWorkflows = [queryQQ|SELECT "id", "graph" FROM "workflow_workflow"|]
+          migrateWorkflow [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
+            swgId <- insertSharedWorkflowGraph graph
+            [executeQQ|UPDATE "workflow_workflow" SET "graph_id" = #{swgId} WHERE "id" = #{wwId}|]
+          migrateWorkflow _ = return ()
+       in runConduit $ getWorkflows .| C.mapM_ migrateWorkflow
+
+      [executeQQ|
+        ALTER TABLE "workflow_workflow" DROP COLUMN "graph";
+        ALTER TABLE "workflow_workflow" ALTER COLUMN "graph_id" SET not null;
+        ALTER TABLE "workflow_workflow" RENAME COLUMN "graph_id" TO "graph";
+      |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Model/Types/Workflow.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Model.Types.Workflow
-  ( WorkflowGraph(..)
+  ( WorkflowGraph(..), WorkflowGraphReference(..)
   , WorkflowGraphNodeLabel
   , WorkflowGraphNode(..)
   , WorkflowNodeView(..)
@@ -37,6 +37,8 @@ import Model.Types.Security (AuthDNF, PredDNF)
 import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..))
 
 import Database.Persist.Sql (PersistFieldSql(..))
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+import Data.ByteArray (ByteArrayAccess)
 
 import Data.Maybe (fromJust)
 
@@ -77,6 +79,15 @@ deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (F
 deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid)
 deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid)
 
+newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField, PersistFieldSql
+                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   , Binary
+                   )
+
 -----  WORKFLOW GRAPH: NODES  -----
 
 newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
@@ -1051,3 +1062,7 @@ instance Binary WorkflowScope'
 instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)
 
 instance Binary userid => Binary (WorkflowRole userid)
+
+-----  TH Jail  -----
+
+makeWrapped ''WorkflowGraphReference

src/Utils/Workflow.hs

@@ -10,6 +10,8 @@ module Utils.Workflow
   , decryptWorkflowStateIndex, encryptWorkflowStateIndex
   , isTopWorkflowScope, isTopWorkflowScopeSql
   , selectWorkflowInstanceDescription
+  , SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
+  , insertSharedWorkflowGraph
   ) where
 
 import Import.NoFoundation
@@ -19,11 +21,15 @@ import qualified Crypto.MAC.KMAC as Crypto
 import qualified Data.ByteArray as BA
 import qualified Data.Binary as Binary
 import Crypto.Hash.Algorithms (SHAKE256)
+import qualified Crypto.Hash as Crypto
 import Language.Haskell.TH (nameBase)
+import qualified Data.Aeson as Aeson
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
 
 type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
 type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
@@ -130,3 +136,35 @@ selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBac
     return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
   descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
   fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
+
+
+data SharedWorkflowGraphException
+  = SharedWorkflowGraphNotFound SharedWorkflowGraphId
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+  
+getSharedDBWorkflowGraph :: ( MonadHandler m
+                            , BackendCompatible SqlReadBackend backend
+                            )
+                         => SharedWorkflowGraphId
+                         -> ReaderT backend m DBWorkflowGraph
+getSharedDBWorkflowGraph swgId = $cachedHereBinary swgId . withReaderT (projectBackend @SqlReadBackend) $ do
+  maybe (liftHandler . throwM $ SharedWorkflowGraphNotFound swgId) (return . sharedWorkflowGraphGraph) =<< get swgId
+  
+getSharedIdWorkflowGraph :: ( MonadHandler m
+                            , BackendCompatible SqlReadBackend backend
+                            )
+                         => SharedWorkflowGraphId
+                         -> ReaderT backend m IdWorkflowGraph
+getSharedIdWorkflowGraph = fmap (review _DBWorkflowGraph) . getSharedDBWorkflowGraph
+
+insertSharedWorkflowGraph :: ( MonadIO m
+                             , BackendCompatible SqlBackend backend
+                             )
+                          => DBWorkflowGraph
+                          -> ReaderT backend m SharedWorkflowGraphId
+insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
+    swgId' <$ repsert swgId' (SharedWorkflowGraph swgId graph)
+  where
+    swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
+    swgId' = SharedWorkflowGraphKey swgId

test/Database/Fill.hs

@@ -34,6 +34,7 @@ import qualified Data.Conduit.Combinators as C
 
 import qualified Data.Yaml as Yaml
 
+import Utils.Workflow
 import Utils.Workflow.Lint
 
 import System.Directory (getModificationTime)
@@ -1330,8 +1331,9 @@ fillDb = do
       displayLinterIssue = liftIO . hPutStrLn stderr . displayException
 
   handleSql displayLinterIssue $ do
-    workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "theses.yaml"
+    graph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "theses.yaml"
-    for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM
+    for_ (lintWorkflowGraph graph) $ mapM_ throwM
+    workflowDefinitionGraph <- insertSharedWorkflowGraph graph
     let
       thesesWorkflowDef = WorkflowDefinition{..}
         where workflowDefinitionInstanceCategory = Just "theses"
@@ -1366,8 +1368,9 @@ fillDb = do
       }
 
   handleSql displayLinterIssue $ do
-    workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "recognitions-ifi.yaml"
+    graph <- Yaml.decodeFileThrow $ testdataDir </> "workflows" </> "recognitions-ifi.yaml"
-    for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM
+    for_ (lintWorkflowGraph graph) $ mapM_ throwM
+    workflowDefinitionGraph <- insertSharedWorkflowGraph graph
     let
       recognitionsWorkflowDef = WorkflowDefinition{..}
         where workflowDefinitionInstanceCategory = Just "recognitions-ifi"