From b814bc094adb09be088c2f8c2750d42f2396bd14 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 1 Feb 2021 17:37:55 +0100 Subject: [PATCH] refactor(workflows): shared workflow graphs --- models/workflows.model | 11 ++-- src/Foundation/Authorization.hs | 19 +++---- src/Foundation/Yesod/Middleware.hs | 3 +- src/Handler/Utils/Workflow/EdgeForm.hs | 17 +++--- src/Handler/Workflow/Definition/Edit.hs | 6 ++- .../Workflow/Definition/Instantiate.hs | 4 +- src/Handler/Workflow/Definition/New.hs | 4 +- src/Handler/Workflow/Instance/Form.hs | 2 +- src/Handler/Workflow/Instance/Initiate.hs | 3 +- src/Handler/Workflow/Instance/New.hs | 3 +- src/Handler/Workflow/Workflow/List.hs | 8 +-- src/Handler/Workflow/Workflow/Workflow.hs | 2 +- src/Jobs.hs | 2 +- src/Jobs/Handler/Files.hs | 4 +- src/Jobs/Offload.hs | 2 +- src/Model/Migration/Definitions.hs | 52 +++++++++++++++++++ src/Model/Types/Workflow.hs | 17 +++++- src/Utils/Workflow.hs | 38 ++++++++++++++ test/Database/Fill.hs | 11 ++-- 19 files changed, 161 insertions(+), 47 deletions(-) diff --git a/models/workflows.model b/models/workflows.model index 590b79744..7561e9c65 100644 --- a/models/workflows.model +++ b/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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index ccfa3b84c..6c76bd8a9 100644 --- a/src/Foundation/Authorization.hs +++ b/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 :: IdWorkflowGraph - wwGraph = _DBWorkflowGraph # workflowWorkflowGraph + wwGraph <- lift $ getSharedIdWorkflowGraph 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 - canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph + 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 diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 473f50de3..df288f3be 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/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' diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index 1e6b033f1..d7b932e82 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/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 - Left WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope - , _DBWorkflowGraph # workflowInstanceGraph - ) - Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope - , _DBWorkflowGraph # workflowWorkflowGraph - ) - wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo + let (scope, sharedGraphId) = case ctx' of + Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope + , workflowInstanceGraph + ) + Right (Entity _ WorkflowWorkflow{..}) -> ( _DBWorkflowScope # workflowWorkflowScope + , workflowWorkflowGraph + ) + 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 diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs index 1f7dbf8cc..1967fc958 100644 --- a/src/Handler/Workflow/Definition/Edit.hs +++ b/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 diff --git a/src/Handler/Workflow/Definition/Instantiate.hs b/src/Handler/Workflow/Definition/Instantiate.hs index 4f0773167..fbac35cd6 100644 --- a/src/Handler/Workflow/Definition/Instantiate.hs +++ b/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 diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs index 898c3b831..827986354 100644 --- a/src/Handler/Workflow/Definition/New.hs +++ b/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 diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs index 549158565..246ac38cf 100644 --- a/src/Handler/Workflow/Instance/Form.hs +++ b/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) diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index f9f5677b2..fda1576d6 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/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 diff --git a/src/Handler/Workflow/Instance/New.hs b/src/Handler/Workflow/Instance/New.hs index c02f6d2e8..e715c62ba 100644 --- a/src/Handler/Workflow/Instance/New.hs +++ b/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 diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index c9333ccbb..97d56fb28 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/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 - hasWorkflowRole' :: WorkflowRole UserId -> DB Bool + WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph + 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{..} diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index f63f95e43..430d8aa59 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 183df06e0..bb06b659c 100644 --- a/src/Jobs.hs +++ b/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' diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index e100c571d..33de12763 100644 --- a/src/Jobs/Handler/Files.hs +++ b/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) - , 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) +workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| 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) ] diff --git a/src/Jobs/Offload.hs b/src/Jobs/Offload.hs index 00d3291cd..2991e03f2 100644 --- a/src/Jobs/Offload.hs +++ b/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 diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8fc1ae10d..baad2c3ec 100644 --- a/src/Model/Migration/Definitions.hs +++ b/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 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index ce27b4f1a..cdea870ed 100644 --- a/src/Model/Types/Workflow.hs +++ b/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 diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs index 8facd298d..5454c150a 100644 --- a/src/Utils/Workflow.hs +++ b/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 diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 654dc024d..b254ca37b 100644 --- a/test/Database/Fill.hs +++ b/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" - for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM + graph <- Yaml.decodeFileThrow $ testdataDir "workflows" "theses.yaml" + 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" - for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM + graph <- Yaml.decodeFileThrow $ testdataDir "workflows" "recognitions-ifi.yaml" + for_ (lintWorkflowGraph graph) $ mapM_ throwM + workflowDefinitionGraph <- insertSharedWorkflowGraph graph let recognitionsWorkflowDef = WorkflowDefinition{..} where workflowDefinitionInstanceCategory = Just "recognitions-ifi"