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

refactor(workflows): shared workflow graphs

Browse Source
This commit is contained in:
Gregor Kleen 2021-02-01 17:37:55 +01:00
parent b0dcbd68fe
commit b814bc094a
19 changed files with 161 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
models/workflows.model
View File

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

19
src/Foundation/Authorization.hs
View File

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

3
src/Foundation/Yesod/Middleware.hs
View File

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

17
src/Handler/Utils/Workflow/EdgeForm.hs
View File

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

6
src/Handler/Workflow/Definition/Edit.hs
View File

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

4
src/Handler/Workflow/Definition/Instantiate.hs
View File

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

4
src/Handler/Workflow/Definition/New.hs
View File

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

2
src/Handler/Workflow/Instance/Form.hs
View File

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

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

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

3
src/Handler/Workflow/Instance/New.hs
View File

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

8
src/Handler/Workflow/Workflow/List.hs
View File

@ -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{..}

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

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

2
src/Jobs.hs
View File

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

4
src/Jobs/Handler/Files.hs
View File

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

2
src/Jobs/Offload.hs
View File

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

52
src/Model/Migration/Definitions.hs
View File

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

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

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

38
src/Utils/Workflow.hs
View File

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

11
test/Database/Fill.hs
View File

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