From 8b32edee64509ca5a3d5fc206192d4fa43cc1971 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 16 Apr 2020 11:42:22 +0200 Subject: [PATCH] feat(workflows): add missing instances; correct Int64 workaround --- models/workflows.model | 12 +-- src/Model/Types/Workflow.hs | 174 +++++++++++++++++++++++++++++++----- 2 files changed, 160 insertions(+), 26 deletions(-) diff --git a/models/workflows.model b/models/workflows.model index 938f18f06..868cc3953 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -1,15 +1,15 @@ WorkflowDefinition - graph (WorkflowGraph UserId FileId) + graph (WorkflowGraph Int64 Int64) scope WorkflowInstanceScope' WorkflowInstance definition WorkflowDefinition - graph (WorkflowGraph UserId FileId) - scope (WorkflowInstaceScope TermId SchoolId CourseId) + graph (WorkflowGraph Int64 Int64) -- FileId, UserId + scope (WorkflowInstanceScope Int64 Int64 Int64) -- TermId, SchoolId, CourseId -Workflow +WorkflowWorkflow instance WorkflowInstance - graph (WorkflowGraph UserId FileId) + graph (WorkflowGraph Int64 Int64) -- FileId, UserId initiator UserId Maybe - payload (WorkflowPayload UserId FileId) + payload (WorkflowPayload Int64 Int64) -- FileId, UserId currentNode WorkflowGraphNodeLabel Maybe diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index b6d532a5d..9f359bfee 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -2,6 +2,7 @@ module Model.Types.Workflow ( WorkflowGraph(..) , WorkflowGraphNodeLabel , WorkflowInstanceScope(..) + , WorkflowInstanceScope'(..) , WorkflowPayload , WorkflowPayload'(..) ) where @@ -10,17 +11,20 @@ import Import.NoModel import Model.Types.Security (AuthDNF) +import Database.Persist.Sql (PersistFieldSql(..)) + import qualified Data.Set as Set (toList) -import qualified Data.Set as Set (toList, fromList) -import qualified Data.Map as Map -import qualified Data.Sequence as Seq +--import qualified Data.Set as Set (toList, fromList) +--import qualified Data.Map as Map +--import qualified Data.Sequence as Seq import Data.Scientific +import Data.Maybe (fromJust) import qualified Data.Aeson as JSON import Data.Aeson.Types (Parser) -- TODO remove -import Data.ByteString.Lazy.Internal (ByteString) +--import Data.ByteString.Lazy.Internal (ByteString) @@ -184,12 +188,14 @@ type WorkflowPayloadLabel = CI Text type WorkflowPayload fileid userid = Map WorkflowPayloadLabel (Seq (WorkflowPayload' fileid userid)) -data WorkflowPayload' fileid userid = forall payload. WorkflowPayload' - { wpPayload :: Map WorkflowPayloadFieldLabel (WorkflowFieldPayload fileid userid payload) +data WorkflowPayload' fileid userid = WorkflowPayload' + { wpPayload :: Map WorkflowPayloadFieldLabel (WorkflowFieldPayloadW fileid userid) , wpActor :: Maybe userid , wpActionTime :: UTCTime } +data WorkflowFieldPayloadW fileid userid = forall payload. WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) + data WorkflowFieldPayload fileid userid (payload :: *) where WFPText :: Text -> WorkflowFieldPayload fileid userid Text WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific @@ -237,17 +243,12 @@ instance (FromJSON userid) => FromJSON (WorkflowRole userid) where instance (ToJSON fileid, ToJSON userid, Ord userid) => ToJSON (WorkflowGraph fileid userid) where toJSON WorkflowGraph{..} = JSON.object - [ "tag" JSON..= ("workflow" :: Text) - , "nodes" JSON..= wgNodes + [ "nodes" JSON..= wgNodes ] 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 fileid userid))) - return WorkflowGraph{..} - _ -> terror $ "WorkflowGraph parseJSON error: expected tag workflow, but got " <> fieldTag + wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid))) + return WorkflowGraph{..} instance (ToJSON userid, ToJSON fileid) => ToJSON (WorkflowGraphEdge userid fileid) where toJSON (WGE{..}) = JSON.object @@ -356,13 +357,146 @@ instance (FromJSON fileid, FromJSON userid, Ord fileid, Ord userid) => FromJSON return WGN{..} +instance (ToJSON termid, ToJSON schoolid, ToJSON courseid) => ToJSON (WorkflowInstanceScope termid schoolid courseid) where + toJSON WISGlobal = JSON.object + [ "tag" JSON..= ("global" :: Text) + ] + toJSON (WISTerm t) = JSON.object + [ "tag" JSON..= ("term" :: Text) + , "term" JSON..= t + ] + toJSON (WISSchool s) = JSON.object + [ "tag" JSON..= ("school" :: Text) + , "school" JSON..= s + ] + toJSON (WISCourse c) = JSON.object + [ "tag" JSON..= ("course" :: Text) + , "course" JSON..= c + ] +instance (FromJSON termid, FromJSON schoolid, FromJSON courseid) => FromJSON (WorkflowInstanceScope termid schoolid courseid) where + parseJSON = JSON.withObject "WorkflowInstanceScope" $ \o -> do + fieldTag <- (o JSON..: "tag" :: Parser Text) + case fieldTag of + "global" -> return WISGlobal + "term" -> do + t <- o JSON..: "term" + return $ WISTerm t + "school" -> do + s <- o JSON..: "school" + return $ WISSchool s + "course" -> do + c <- o JSON..: "course" + return $ WISCourse c + _ -> terror $ "WorkflowInstanceScope parseJSON error: expected field tag (global|term|school|course), but got " <> fieldTag + + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 . fromJust . stripSuffix "'" + } ''WorkflowInstanceScope' +derivePersistFieldJSON ''WorkflowInstanceScope' + + +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayload' fileid userid) where + toJSON WorkflowPayload'{..} = JSON.object + [ "payload" JSON..= wpPayload + , "actor" JSON..= wpActor + , "action-time" JSON..= wpActionTime + ] +instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowPayload' fileid userid) where + parseJSON = JSON.withObject "WorkflowPayload'" $ \o -> do + wpPayload <- o JSON..: "payload" + wpActor <- o JSON..:? "actor" + wpActionTime <- o JSON..: "action-time" + return WorkflowPayload'{..} + +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where + toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object + [ "tag" JSON..= ("text" :: Text) + , "text" JSON..= t + ] + toJSON (WorkflowFieldPayloadW (WFPNumber n)) = JSON.object + [ "tag" JSON..= ("number" :: Text) + , "number" JSON..= n + ] + toJSON (WorkflowFieldPayloadW (WFPBool b)) = JSON.object + [ "tag" JSON..= ("bool" :: Text) + , "bool" JSON..= b + ] + toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object + [ "tag" JSON..= ("file" :: Text) + , "file" JSON..= fid + ] + toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object + [ "tag" JSON..= ("user" :: Text) + , "user" JSON..= uid + ] +instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where + parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do + fieldTag <- (o JSON..: "tag" :: Parser Text) + case fieldTag of + "text" -> do + t <- o JSON..: "text" + return $ WorkflowFieldPayloadW $ WFPText t + "number" -> do + n <- o JSON..: "number" + return $ WorkflowFieldPayloadW $ WFPNumber n + "bool" -> do + b <- o JSON..: "bool" + return $ WorkflowFieldPayloadW $ WFPBool b + "file" -> do + fid <- o JSON..: "file" + return $ WorkflowFieldPayloadW $ WFPFile fid + "user" -> do + uid <- o JSON..: "user" + return $ WorkflowFieldPayloadW $ WFPUser uid + _ -> terror $ "WorkflowFieldPayloadW parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag + + + +----- PersistField / PersistFieldSql instances ----- + +instance ( ToJSON fileid, ToJSON userid + , FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + ) => PersistField (WorkflowGraph fileid userid) where + toPersistValue = toPersistValueJSON + fromPersistValue = fromPersistValueJSON +instance ( ToJSON fileid, ToJSON userid + , FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + ) => PersistFieldSql (WorkflowGraph fileid userid) where + sqlType _ = SqlString + + +instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid + , FromJSON termid, FromJSON schoolid, FromJSON courseid + ) => PersistField (WorkflowInstanceScope termid schoolid courseid) where + toPersistValue = toPersistValueJSON + fromPersistValue = fromPersistValueJSON +instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid + , FromJSON termid, FromJSON schoolid, FromJSON courseid + ) => PersistFieldSql (WorkflowInstanceScope termid schoolid courseid) where + sqlType _ = SqlString + + +instance ( ToJSON fileid, ToJSON userid + , FromJSON fileid, FromJSON userid + ) => PersistField (WorkflowPayload fileid userid) where + toPersistValue = toPersistValueJSON + fromPersistValue = fromPersistValueJSON +instance ( ToJSON fileid, ToJSON userid + , FromJSON fileid, FromJSON userid + ) => PersistFieldSql (WorkflowPayload fileid userid) where + sqlType _ = SqlString + + ----- TEST DEFS (TODO remove) ----- -testGraph :: WorkflowGraph Text Text -testGraph = WorkflowGraph $ Map.fromList [("node1", WGN (Just "someLabel") True (Set.fromList [WGE "node1" (Set.fromList [WorkflowRoleUser "user-id", WorkflowRoleInitiator]) (Map.fromList [("sometext", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldText "text-label" "text-placeholder" (Just "text-tooltip") (Just "text-default") Nothing]),("someuser", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldUser "user-label" Nothing Nothing Nothing]),("someboolandnumber-opt", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldBool "bool-label" Nothing (Just True), WorkflowPayloadSpec $ WorkflowPayloadFieldNumber "number-label" "number-placeholder" Nothing Nothing (Just 1) (Just 5) 0.01 (Just True)])])]))] +--testGraph :: WorkflowGraph Text Text +--testGraph = WorkflowGraph $ Map.fromList [("node1", WGN (Just "someLabel") True (Set.fromList [WGE "node1" (Set.fromList [WorkflowRoleUser "user-id", WorkflowRoleInitiator]) (Map.fromList [("sometext", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldText "text-label" "text-placeholder" (Just "text-tooltip") (Just "text-default") Nothing]),("someuser", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldUser "user-label" Nothing Nothing Nothing]),("someboolandnumber-opt", impureNonNull $ Set.fromList [WorkflowPayloadSpec $ WorkflowPayloadFieldBool "bool-label" Nothing (Just True), WorkflowPayloadSpec $ WorkflowPayloadFieldNumber "number-label" "number-placeholder" Nothing Nothing (Just 1) (Just 5) 0.01 (Just True)])])]))] -testGraphStr :: Data.ByteString.Lazy.Internal.ByteString -testGraphStr = "{\"tag\":\"workflow\",\"nodes\":{\"node1\":{\"display-label\":\"node-label\",\"finished\":true,\"edges\":[{\"actors\":[{\"tag\":\"initiator\"},{\"tag\":\"user\",\"user\":\"user-id\"},{\"tag\":\"authorized\",\"authorized\":{\"dnf\":{\"dnfTerms\":[[{\"plVar\":\"lecturer\",\"val\":\"variable\"},{\"plVar\":\"participant\",\"val\":\"negated\"}]]}}}],\"form\":{\"some-number\":[{\"tag\":\"number\",\"step\":0.01,\"label\":\"number-label\",\"placeholder\":\"number-placeholder\"}]},\"target\":\"node1\"}]}}}" +--testGraphStr :: Data.ByteString.Lazy.Internal.ByteString +--testGraphStr = "{\"nodes\":{\"node1\":{\"display-label\":\"node-label\",\"finished\":true,\"edges\":[{\"actors\":[{\"tag\":\"initiator\"},{\"tag\":\"user\",\"user\":\"user-id\"},{\"tag\":\"authorized\",\"authorized\":{\"dnf\":{\"dnfTerms\":[[{\"plVar\":\"lecturer\",\"val\":\"variable\"},{\"plVar\":\"participant\",\"val\":\"negated\"}]]}}}],\"form\":{\"some-number\":[{\"tag\":\"number\",\"step\":0.01,\"label\":\"number-label\",\"placeholder\":\"number-placeholder\"}]},\"target\":\"node1\"}]}}}" -testPayload :: WorkflowPayload Text Text -testPayload = Map.fromList [("sometext" :: WorkflowPayloadLabel, (Seq.singleton (WorkflowPayload' (Map.fromList [("text-label", WFPText "hello world!")]) (Just "actor-user-id" :: Maybe Text) (UTCTime (ModifiedJulianDay 58946) 57250))))] +--testPayload :: WorkflowPayload Text Text +--testPayload = Map.fromList [("sometext" :: WorkflowPayloadLabel, (Seq.singleton (WorkflowPayload' (Map.fromList [("text-label", WFPText "hello world!")]) (Just "actor-user-id" :: Maybe Text) (UTCTime (ModifiedJulianDay 58946) 57250))))]