feat(workflows): add missing instances; correct Int64 workaround

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)
+    graph       (WorkflowGraph Int64 Int64)  -- FileId, UserId
-    scope       (WorkflowInstaceScope TermId SchoolId CourseId)
+    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

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.Set as Set (toList, fromList)
-import qualified Data.Map as Map
+--import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
+--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'
+data WorkflowPayload' fileid userid = WorkflowPayload'
-  { wpPayload    :: Map WorkflowPayloadFieldLabel (WorkflowFieldPayload fileid userid payload)
+  { 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"
+    wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)))
-    case fieldTag of
+    return WorkflowGraph{..}
-      "workflow" -> do
-        wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)))
-        return WorkflowGraph{..}
-      _ -> terror $ "WorkflowGraph parseJSON error: expected tag workflow, but got " <> fieldTag
 
 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 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 $ 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 :: 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 = "{\"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 :: 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 = Map.fromList [("sometext" :: WorkflowPayloadLabel, (Seq.singleton (WorkflowPayload' (Map.fromList [("text-label", WFPText "hello world!")]) (Just "actor-user-id" :: Maybe Text) (UTCTime (ModifiedJulianDay 58946) 57250))))]