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

refactor(workflows): rework types and instances

Browse Source
This commit is contained in:
Sarah Vaupel 2020-04-23 17:13:39 +02:00 committed by Gregor Kleen
parent 386d3bfc49
commit c2169423e6
1 changed files with 23 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,28 +27,28 @@ import Data.Aeson.Types (Parser)
-- TODO remove
--import Data.ByteString.Lazy.Internal (ByteString)
-- TODO: label type to newtype
----- WORKFLOW GRAPH -----
data WorkflowGraph fileid userid = WorkflowGraph
{ wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)
, wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set WorkflowRole))
, wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowRole userid)))
}
deriving (Show, Eq)
----- WORKFLOW GRAPH: NODES -----
type WorkflowGraphNodeLabel = CI Text
type WorkflowGraphEdgeLabel = CI Text
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel (CI Text)
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel (CI Text)
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
data WorkflowGraphNode fileid userid = WGN
{ wgnDisplayLabel :: Maybe Text
, wgnInitial :: Bool
, wgnFinished :: Bool
, wgnViewers :: Set WorkflowRole
, wgnViewers :: Set (WorkflowRole userid)
, wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
}
deriving (Eq, Ord, Show, Generic, Typeable)
@ -87,7 +87,8 @@ data WorkflowPayloadSpec fileid userid = forall payload. WorkflowPayloadSpec (Wo
instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid) where
show (WorkflowPayloadSpec payloadField) = show payloadField
type WorkflowPayloadFieldLabel = CI Text
newtype WorkflowPayloadFieldLabel = WorkflowPayloadFieldLabel (CI Text)
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldText :: { wpftLabel :: Text
@ -193,7 +194,8 @@ data WorkflowInstanceScope' = WISGlobal' | WISTerm' | WISSchool' | WISCourse'
----- WORKFLOW: PAYLOAD -----
type WorkflowPayloadLabel = CI Text
newtype WorkflowPayloadLabel = WorkflowPayloadLabel (CI Text)
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
type WorkflowPayload fileid userid = Map WorkflowPayloadLabel (Seq (WorkflowPayload' fileid userid))
@ -256,18 +258,16 @@ instance (FromJSON userid) => FromJSON (WorkflowRole userid) where
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where
toJSON WorkflowGraph{..} = JSON.object
[ "nodes" JSON..= wgNodes
[ "nodes" JSON..= wgNodes
, "payload-viewers" JSON..= wgPayloadViewers
]
instance (FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid
) => FromJSON (WorkflowGraph fileid userid) where
parseJSON = JSON.withObject "WorkflowGraph" $ \o -> do
fieldTag <- o JSON..: "tag"
case fieldTag of
"workflow" -> do
wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel WorkflowGraphNode))
return WorkflowGraph{..}
_ -> terror $ "WorkflowGraph parseJSON error: expected tag workflow, but got " <> fieldTag
wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)))
wgPayloadViewers <- o JSON..: "payload-viewers"
return WorkflowGraph{..}
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphEdge fileid userid) where
toJSON (WGE{..}) = JSON.object
@ -279,9 +279,10 @@ instance (FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid
) => FromJSON (WorkflowGraphEdge fileid userid) where
parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do
wgeActors <- o JSON..: "actors"
wgeTarget <- o JSON..: "target"
wgeForm <- o JSON..: "form"
wgeActors <- o JSON..: "actors"
wgeTarget <- o JSON..: "target"
wgeAutomatic <- o JSON..: "automatic"
wgeForm <- o JSON..: "form"
return WGE{..}
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid userid) where
@ -369,7 +370,9 @@ instance (FromJSON fileid, FromJSON userid
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphNode fileid userid) where
toJSON WGN{..} = JSON.object
[ "display-label" JSON..= wgnDisplayLabel
, "initial" JSON..= wgnInitial
, "finished" JSON..= wgnFinished
, "viewers" JSON..= wgnViewers
, "edges" JSON..= wgnEdges
]
instance (FromJSON fileid, FromJSON userid
@ -377,7 +380,9 @@ instance (FromJSON fileid, FromJSON userid
) => FromJSON (WorkflowGraphNode fileid userid) where
parseJSON = JSON.withObject "WorkflowGraphNode" $ \o -> do
wgnDisplayLabel <- o JSON..: "display-label"
wgnInitial <- o JSON..: "initial"
wgnFinished <- o JSON..: "finished"
wgnViewers <- o JSON..: "viewers"
wgnEdges <- o JSON..: "edges"
return WGN{..}