From 8943c3e3bfd046324aaf9b93ecfeab3b9b3607f8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 8 May 2020 15:07:38 +0200 Subject: [PATCH] refactor(workflows): rework types & instances --- models/workflows.model | 15 +- src/Import/NoModel.hs | 2 +- src/Model.hs | 5 + src/Model/Types/Security.hs | 6 +- src/Model/Types/TH/JSON.hs | 55 ++-- src/Model/Types/Workflow.hs | 501 ++++++++++++++++-------------------- 6 files changed, 271 insertions(+), 313 deletions(-) diff --git a/models/workflows.model b/models/workflows.model index 325861bd6..630e7ff07 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -1,20 +1,21 @@ WorkflowDefinition - graph WorkflowGraph + graph (WorkflowGraph SqlBackendKey SqlBackendKey) scope WorkflowInstanceScope' name (CI Text) UniqueWorkflowDefinition name scope WorkflowInstance definition WorkflowDefinition - graph (WorkflowGraph Int64 Int64) -- FileId, UserId - scope (WorkflowInstanceScope Int64 Int64 Int64) -- TermId, SchoolId, CourseId + graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId + scope (WorkflowInstanceScope SqlBackendKey SqlBackendKey SqlBackendKey) -- TermId, SchoolId, CourseId name (CI Text) category (CI Text) Maybe UniqueWorkflowInstance name scope WorkflowWorkflow instance WorkflowInstance - graph WorkflowGraph - initiator UserId Maybe - payload WorkflowPayload - currentNode WorkflowGraphNodeLabel Maybe + graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId + initUser UserId Maybe + initTime UTCTime + state (WorkflowState SqlBackendKey SqlBackendKey) -- FileId, UserId + currentNode WorkflowGraphNodeLabel diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 0f29237c5..4ae319b29 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -7,7 +7,7 @@ module Import.NoModel import ClassyPrelude.Yesod as Import hiding ( formatTime - , derivePersistFieldJSON + , derivePersistFieldJSON, toPersistValueJSON, fromPersistValueJSON , getMessages, addMessage, addMessageI , (.=) , MForm diff --git a/src/Model.hs b/src/Model.hs index b450990ec..aa13508f6 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -21,6 +21,11 @@ import Settings.Cluster (ClusterSettingsKey) import Text.Blaze (ToMarkup(..)) +import Database.Persist.Sql (BackendKey(..)) + + +type SqlBackendKey = BackendKey SqlBackend + -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 9df7be8ab..7f6c5b617 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -89,8 +89,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthDeprecated | AuthDevelopment | AuthFree - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite, Hashable) + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) + deriving anyclass (Universe, Finite, Hashable, Binary) nullaryPathPiece ''AuthTag $ camelToPathPiece' 1 pathPieceJSON ''AuthTag @@ -149,7 +149,7 @@ instance PathPiece a => PathPiece (PredLiteral a) where newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } - deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (Semigroup, Monoid) deriving anyclass (Binary, Hashable) diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index c1ca6a88a..c63aa30db 100644 --- a/src/Model/Types/TH/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -1,11 +1,8 @@ -module Model.Types.TH.JSON - ( derivePersistFieldJSON - , predNFAesonOptions - ) where +module Model.Types.TH.JSON where -import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) +import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, toPersistValueJSON, fromPersistValueJSON) import Data.List (foldl) -import Database.Persist.Sql +import Database.Persist.Sql hiding (toPersistValueJSON, fromPersistValueJSON) import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Encoding as Text @@ -18,6 +15,21 @@ import Language.Haskell.TH.Datatype import Utils.PathPiece +toPersistValueJSON :: ToJSON a => a -> PersistValue +toPersistValueJSON = PersistDbSpecific . LBS.toStrict . JSON.encode + +fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a +fromPersistValueJSON = \case + PersistDbSpecific bs -> decodeBS bs + PersistByteString bs -> decodeBS bs + PersistText text -> decodeBS $ Text.encodeUtf8 text + _other -> Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString" + where decodeBS = first pack . JSON.eitherDecodeStrict' + +sqlTypeJSON :: SqlType +sqlTypeJSON = SqlOther "jsonb" + + derivePersistFieldJSON :: Name -> DecsQ derivePersistFieldJSON tName = do DatatypeInfo{..} <- reifyDatatype tName @@ -32,24 +44,15 @@ derivePersistFieldJSON tName = do sequence [ instanceD iCxt ([t|PersistField|] `appT` t) [ funD 'toPersistValue - [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) [] + [ clause [] (normalB [e|toPersistValueJSON|]) [] ] , funD 'fromPersistValue - [ do - bs <- newName "bs" - clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) [] - , do - bs <- newName "bs" - clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) [] - , do - text <- newName "text" - clause [[p|PersistText $(varP text)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE text)|]) [] - , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) [] + [ clause [] (normalB [e|fromPersistValueJSON|]) [] ] ] , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) [ funD 'sqlType - [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) [] + [ clause [wildP] (normalB [e|sqlTypeJSON|]) [] ] ] ] @@ -64,4 +67,20 @@ predNFAesonOptions = defaultOptions , sumEncoding = ObjectWithSingleField , tagSingleConstructors = True } + +workflowGraphAesonOptions, workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions :: Options +workflowGraphAesonOptions = defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } +workflowGraphEdgeAesonOptions = defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "mode" $ error "There should be no field called ‘mode’" + } +workflowGraphNodeAesonOptions = defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } +workflowActionAesonOptions = defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 838a1a05d..591066acf 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -3,29 +3,26 @@ module Model.Types.Workflow , WorkflowGraphNodeLabel , WorkflowInstanceScope(..) , WorkflowInstanceScope'(..) - , WorkflowPayload(..) - , WorkflowPayload'(..) + , WorkflowState + , WorkflowAction(..) ) where import Import.NoModel import Model.Types.Security (AuthDNF) ---import Model.Types.Security (AuthDNF, PredDNF(..), AuthTag(..), PredLiteral(..)) 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 Data.Scientific import Data.Maybe (fromJust) +import Data.Aeson (genericToJSON, genericParseJSON) import qualified Data.Aeson as JSON +import qualified Data.Aeson.Types as JSON +import Data.Aeson.Lens (_Null) import Data.Aeson.Types (Parser) --- TODO remove ---import Data.ByteString.Lazy.Internal (ByteString) +import Type.Reflection (eqTypeRep, typeOf, (:~~:)(..)) ----- WORKFLOW GRAPH ----- @@ -34,15 +31,17 @@ data WorkflowGraph fileid userid = WorkflowGraph { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) , wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowRole userid))) } - deriving (Show, Eq) + deriving (Eq, Ord, Show, Generic, Typeable) ----- WORKFLOW GRAPH: NODES ----- -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) +newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } + deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) +newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } + deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) data WorkflowGraphNode fileid userid = WGN { wgnDisplayLabel :: Maybe Text @@ -56,157 +55,166 @@ data WorkflowGraphNode fileid userid = WGN ----- WORKFLOW GRAPH: EDGES ----- -data WorkflowGraphEdge fileid userid = WGE - { wgeTarget :: WorkflowGraphNodeLabel - , wgeAutomatic :: Bool - , wgeActors :: Set (WorkflowRole userid) - , wgeForm :: NonNull (Map WorkflowPayloadLabel (WorkflowPayloadSpec fileid userid)) - } - deriving Show - -instance (Eq fileid, Eq userid) => Eq (WorkflowGraphEdge fileid userid) where - e1@WGE{} == e2@WGE{} = wgeTarget e1 == wgeTarget e2 && wgeActors e1 == wgeActors e2 && wgeForm e1 == wgeForm e2 - -instance (Ord fileid, Ord userid) => Ord (WorkflowGraphEdge fileid userid) where - compare = mconcat [comparing wgeTarget, comparing wgeActors, comparing wgeForm] +data WorkflowGraphEdge fileid userid + = WorkflowGraphEdgeManual + { wgeTarget :: WorkflowGraphNodeLabel + , wgeActors :: Set (WorkflowRole userid) + , wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid userid))) + -- ^ field requirement forms a cnf: + -- + -- - all labels must be filled + -- - for each label any field must be filled + -- - optional fields are always considered to be filled + -- + -- since fields can reference other labels this allows arbitrary requirements to be encoded. + } + | WorkflowGraphEdgeAutomatic + { wgeTarget :: WorkflowGraphNodeLabel + } + deriving (Eq, Ord, Show, Generic, Typeable) ----- WORKFLOW GRAPH: ROLES / ACTORS ----- data WorkflowRole userid - = WorkflowRoleUser userid - | WorkflowRoleAuthorized AuthDNF - | WorkflowRoleInitiator - deriving (Eq, Ord, Show, Read, Generic, Typeable) + = WorkflowRoleUser { workflowRoleUser :: userid } + | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF } + | WorkflowRoleInitiator + deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) ----- WORKFLOW GRAPH: PAYLOAD SPECIFICATION ----- -data WorkflowPayloadSpec fileid userid = forall payload. WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) +data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) + deriving (Typeable) -instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid) where - show (WorkflowPayloadSpec payloadField) = show payloadField - -newtype WorkflowPayloadFieldLabel = WorkflowPayloadFieldLabel (CI Text) - deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) +deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid) data WorkflowPayloadField fileid userid (payload :: Type) where - WorkflowPayloadFieldText :: { wpftLabel :: Text - , wpftPlaceholder :: Text - , wpftTooltip :: Maybe Text - , wpftDefault :: Maybe Text - , wpftOptional :: Maybe Bool - } -> WorkflowPayloadField fileid userid Text - WorkflowPayloadFieldNumber :: { wpfnLabel :: Text - , wpfnPlaceholder :: Text - , wpfnTooltip :: Maybe Text - , wpfnDefault :: Maybe Scientific - , wpfnMin :: Maybe Scientific - , wpfnMax :: Maybe Scientific - , wpfnStep :: Scientific - , wpfnOptional :: Maybe Bool - } -> WorkflowPayloadField fileid userid Scientific - WorkflowPayloadFieldBool :: { wpfbLabel :: Text - , wpfbTooltip :: Maybe Text - , wpfbDefault :: Maybe Bool - } -> WorkflowPayloadField fileid userid Bool - WorkflowPayloadFieldFile :: { wpffLabel :: Text - , wpffTooltip :: Maybe Text - , wpffDefault :: Maybe fileid - , wpffOptional :: Maybe Bool - } -> WorkflowPayloadField fileid userid FileInfo - WorkflowPayloadFieldUser :: { wpfuLabel :: Text - , wpfuTooltip :: Maybe Text - , wpfuDefault :: Maybe userid - , wpfuOptional :: Maybe Bool - } -> WorkflowPayloadField fileid userid userid + WorkflowPayloadFieldText :: { wpftLabel :: Text + , wpftPlaceholder :: Maybe Text + , wpftTooltip :: Maybe Text + , wpftDefault :: Maybe Text + , wpftOptional :: Bool + } -> WorkflowPayloadField fileid userid Text + WorkflowPayloadFieldNumber :: { wpfnLabel :: Text + , wpfnPlaceholder :: Maybe Text + , wpfnTooltip :: Maybe Text + , wpfnDefault + , wpfnMin + , wpfnMax + , wpfnStep :: Maybe Scientific + , wpfnOptional :: Bool + } -> WorkflowPayloadField fileid userid Scientific + WorkflowPayloadFieldBool :: { wpfbLabel :: Text + , wpfbTooltip :: Maybe Text + , wpfbDefault :: Maybe Bool + , wpfbOptional :: Maybe Text -- ^ Optional if `Just`; encodes label of `Nothing`-Option + } -> WorkflowPayloadField fileid userid Bool + WorkflowPayloadFieldFile :: { wpffLabel :: Text + , wpffTooltip :: Maybe Text + , wpffDefault :: Maybe fileid + , wpffOptional :: Bool + } -> WorkflowPayloadField fileid userid FileInfo + WorkflowPayloadFieldUser :: { wpfuLabel :: Text + , wpfuTooltip :: Maybe Text + , wpfuDefault :: Maybe userid + , wpfuOptional :: Bool + } -> WorkflowPayloadField fileid userid userid + WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel + } -> WorkflowPayloadField fileid userid (NonNull (Set (WorkflowFieldPayloadW fileid userid))) + deriving (Typeable) -instance (Show fileid, Show userid) => Show (WorkflowPayloadField fileid userid payload) where - show (WorkflowPayloadFieldText{..} ) = "TextField{label = " <> show wpftLabel - <> ", placeholder = " <> show wpftPlaceholder - <> ", tooltip = " <> show wpftTooltip - <> ", default = " <> show wpftDefault - <> ", optional = " <> show wpftOptional - <> "}" - show (WorkflowPayloadFieldNumber{..}) = "NumberField{label = " <> show wpfnLabel - <> ", placeholder = " <> show wpfnPlaceholder - <> ", tooltip = " <> show wpfnTooltip - <> ", default = " <> show wpfnDefault - <> ", min = " <> show wpfnMin - <> ", max = " <> show wpfnMax - <> ", step = " <> show wpfnStep - <> ", optional = " <> show wpfnOptional - <> "}" - show (WorkflowPayloadFieldBool{..} ) = "BoolField{label = " <> show wpfbLabel - <> ", tooltip = " <> show wpfbTooltip - <> ", default = " <> show wpfbDefault - <> "}" - show (WorkflowPayloadFieldFile{..} ) = "FileField{label = " <> show wpffLabel - <> ", tooltip = " <> show wpffTooltip - <> ", default = " <> show wpffDefault - <> ", optional = " <> show wpffOptional - <> "}" - show (WorkflowPayloadFieldUser{..} ) = "UserField{label = " <> show wpfuLabel - <> ", tooltip = " <> show wpfuTooltip - <> ", default = " <> show wpfuDefault - <> ", optional = " <> show wpfuOptional - <> "}" +deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadField fileid userid payload) +deriving instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadField fileid userid payload) +deriving instance (Ord fileid, Ord userid) => Ord (WorkflowPayloadField fileid userid payload) -instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadSpec fileid userid) where - (WorkflowPayloadSpec f1@WorkflowPayloadFieldText{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldText{}) = wpftLabel f1 == wpftLabel f2 && wpftPlaceholder f1 == wpftPlaceholder f2 && wpftTooltip f1 == wpftTooltip f2 && wpftDefault f1 == wpftDefault f2 && wpftOptional f1 == wpftOptional f2 - (WorkflowPayloadSpec f1@WorkflowPayloadFieldNumber{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldNumber{}) = wpfnLabel f1 == wpfnLabel f2 && wpfnPlaceholder f1 == wpfnPlaceholder f2 && wpfnTooltip f1 == wpfnTooltip f2 && wpfnDefault f1 == wpfnDefault f2 && wpfnOptional f1 == wpfnOptional f2 - (WorkflowPayloadSpec f1@WorkflowPayloadFieldBool{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldBool{}) = wpfbLabel f1 == wpfbLabel f2 && wpfbTooltip f1 == wpfbTooltip f2 && wpfbDefault f1 == wpfbDefault f2 - (WorkflowPayloadSpec f1@WorkflowPayloadFieldFile{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldFile{}) = wpffLabel f1 == wpffLabel f2 && wpffTooltip f1 == wpffTooltip f2 && wpffDefault f1 == wpffDefault f2 && wpffOptional f1 == wpffOptional f2 - (WorkflowPayloadSpec f1@WorkflowPayloadFieldUser{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldUser{}) = wpfuLabel f1 == wpfuLabel f2 && wpfuTooltip f1 == wpfuTooltip f2 && wpfuDefault f1 == wpfuDefault f2 && wpfuOptional f1 == wpfuOptional f2 - _ == _ = False +instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowPayloadSpec fileid userid) where + (WorkflowPayloadSpec a) == (WorkflowPayloadSpec b) + = case typeOf a `eqTypeRep` typeOf b of + Just HRefl -> a == b + Nothing -> False -instance (Ord fileid, Ord userid) => Ord (WorkflowPayloadSpec fileid userid) where - compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldText{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldText{}) = mconcat [comparing wpftLabel, comparing wpftPlaceholder, comparing wpftTooltip, comparing wpftDefault, comparing wpftOptional] f1 f2 - compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldNumber{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldNumber{}) = mconcat [comparing wpfnLabel, comparing wpfnPlaceholder, comparing wpfnTooltip, comparing wpfnDefault, comparing wpfnMin, comparing wpfnMax, comparing wpfnStep, comparing wpfnOptional] f1 f2 - compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldBool{}) = mconcat [comparing wpfbLabel, comparing wpfbTooltip, comparing wpfbDefault] f1 f2 - compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldFile{}) = mconcat [comparing wpffLabel, comparing wpffTooltip, comparing wpffDefault, comparing wpffOptional] f1 f2 - compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldUser{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldUser{}) = mconcat [comparing wpfuLabel, comparing wpfuTooltip, comparing wpfuDefault, comparing wpfuOptional] f1 f2 - compare (WorkflowPayloadSpec WorkflowPayloadFieldText{} ) _ = LT - compare (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) _ = LT - compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) _ = LT - compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) = GT - compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) _ = LT - compare (WorkflowPayloadSpec WorkflowPayloadFieldUser{}) _ = LT +instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (WorkflowPayloadSpec fileid userid) where + (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b) + = case typeOf a `eqTypeRep` typeOf b of + Just HRefl -> a `compare` b + Nothing -> case (a, b) of + (WorkflowPayloadFieldText{}, _) -> LT + (WorkflowPayloadFieldNumber{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldNumber{}, _) -> LT + (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldBool{}, _) -> LT + (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldBool{}) -> GT + (WorkflowPayloadFieldFile{}, _) -> LT + (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT + (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT + (WorkflowPayloadFieldUser{}, _) -> LT + (WorkflowPayloadFieldReference{}, _) -> GT ----- WORKFLOW INSTANCE ----- data WorkflowInstanceScope termid schoolid courseid - = WISGlobal - | WISTerm termid - | WISSchool schoolid - | WISCourse courseid + = WISGlobal + | WISTerm { wisTerm :: termid } + | WISSchool { wisSchool :: schoolid } + | WISCourse { wisCourse :: courseid } deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) -data WorkflowInstanceScope' = WISGlobal' | WISTerm' | WISSchool' | WISCourse' - deriving (Eq, Ord, Enum, Read, Show, Data, Generic, Typeable) +data WorkflowInstanceScope' + = WISGlobal' | WISTerm' | WISSchool' | WISCourse' + deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) + deriving anyclass (Universe, Finite) ----- WORKFLOW: PAYLOAD ----- -newtype WorkflowPayloadLabel = WorkflowPayloadLabel (CI Text) - deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) +newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } + deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) + deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) -type WorkflowPayload fileid userid = Map WorkflowPayloadLabel (Seq (WorkflowPayload' fileid userid)) +type WorkflowState fileid userid = Seq (WorkflowAction fileid userid) -data WorkflowPayload' fileid userid = WorkflowPayload' - { wpPayload :: Map WorkflowGraphNodeLabel (Map WorkflowGraphEdgeLabel (Map WorkflowPayloadFieldLabel (WorkflowFieldPayloadW fileid userid))) - , wpActor :: Maybe userid - , wpActionTime :: UTCTime +data WorkflowAction fileid userid = WorkflowAction + { wpFrom :: WorkflowGraphNodeLabel + , wpVia :: WorkflowGraphEdgeLabel + , wpPayload :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowFieldPayloadW fileid userid))) + , wpUser :: Maybe (Maybe userid) -- ^ Outer `Maybe` encodes automatic/manual, inner `Maybe` encodes whether user was authenticated + , wpTime :: UTCTime } - deriving Show + deriving (Eq, Ord, Show, Generic, Typeable) -data WorkflowFieldPayload = forall payload. WorkflowFieldPayload (WorkflowFieldPayload' payload) +data WorkflowFieldPayloadW fileid userid = forall payload. Typeable payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) + deriving (Typeable) + +instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where + (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b) + = case typeOf a `eqTypeRep` typeOf b of + Just HRefl -> a == b + Nothing -> False + +instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (WorkflowFieldPayloadW fileid userid) where + (WorkflowFieldPayloadW a) `compare` (WorkflowFieldPayloadW b) + = case typeOf a `eqTypeRep` typeOf b of + Just HRefl -> a `compare` b + Nothing -> case (a, b) of + (WFPText{}, _) -> LT + (WFPNumber{}, WFPText{}) -> GT + (WFPNumber{}, _) -> LT + (WFPBool{}, WFPText{}) -> GT + (WFPBool{}, WFPNumber{}) -> GT + (WFPBool{}, _) -> LT + (WFPFile{}, WFPText{}) -> GT + (WFPFile{}, WFPNumber{}) -> GT + (WFPFile{}, WFPBool{}) -> GT + (WFPFile{}, _) -> LT + (WFPUser{}, _) -> GT instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where show (WorkflowFieldPayloadW payload) = show payload @@ -217,76 +225,45 @@ data WorkflowFieldPayload fileid userid (payload :: Type) where WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid WFPUser :: userid -> WorkflowFieldPayload fileid userid userid + deriving (Typeable) -instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload) where - show (WFPText wfptText ) = "WFPText{text = " <> show wfptText <> "}" - show (WFPNumber wfpnNumber) = "WFPNumber{number = " <> show wfpnNumber <> "}" - show (WFPBool wfpbBool ) = "WFPBool{bool = " <> show wfpbBool <> "}" - show (WFPFile wfpfFile ) = "WFPFile{file = " <> show wfpfFile <> "}" - show (WFPUser wfpuUser ) = "WFPUser{user = " <> show wfpuUser <> "}" +deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload) +deriving instance (Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) +deriving instance (Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPUser' - deriving (Eq, Ord, Enum, Show, Read, Data, Generic, Typeable) + deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) + deriving anyclass (Universe, Finite) ----- ToJSON / FromJSON instances ----- -instance (ToJSON userid) => ToJSON (WorkflowRole userid) where - toJSON (WorkflowRoleUser uid) = JSON.object - [ "tag" JSON..= ("user" :: Text) - , "user" JSON..= uid - ] - toJSON (WorkflowRoleAuthorized authDNF) = JSON.object - [ "tag" JSON..= ("authorized" :: Text) - , "authorized" JSON..= authDNF - ] - toJSON WorkflowRoleInitiator = JSON.object - [ "tag" JSON..= ("initiator" :: Text) - ] -instance (FromJSON userid) => FromJSON (WorkflowRole userid) where - parseJSON = JSON.withObject "WorkflowRole" $ \o -> do - fieldTag <- (o JSON..: "tag" :: Parser Text) - case fieldTag of - "user" -> do - uid <- o JSON..: "user" - return $ WorkflowRoleUser uid - "authorized" -> do - adnf <- o JSON..: "authorized" - return $ WorkflowRoleAuthorized adnf - "initiator" -> return WorkflowRoleInitiator - _ -> terror $ "WorkflowRole parseJSON error: expected role (user|authorized|initiator), but got " <> fieldTag +omitNothing :: [JSON.Pair] -> [JSON.Pair] +omitNothing = filter . hasn't $ _2 . _Null + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 2 + , constructorTagModifier = camelToPathPiece' 2 + } ''WorkflowRole instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where - toJSON WorkflowGraph{..} = JSON.object - [ "nodes" JSON..= wgNodes - , "payload-viewers" JSON..= wgPayloadViewers - ] -instance (FromJSON fileid, FromJSON userid - , Ord fileid, Ord userid + toJSON = genericToJSON workflowGraphAesonOptions +instance ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid ) => FromJSON (WorkflowGraph fileid userid) where - parseJSON = JSON.withObject "WorkflowGraph" $ \o -> do - wgNodes <- (o JSON..: "nodes" :: Parser (Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid))) - wgPayloadViewers <- o JSON..: "payload-viewers" - return WorkflowGraph{..} + parseJSON = genericParseJSON workflowGraphAesonOptions instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphEdge fileid userid) where - toJSON (WGE{..}) = JSON.object - [ "actors" JSON..= Set.toList wgeActors - , "target" JSON..= wgeTarget - , "form" JSON..= wgeForm - ] -instance (FromJSON fileid, FromJSON userid - , Ord fileid, Ord userid + toJSON = genericToJSON workflowGraphEdgeAesonOptions +instance ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid ) => FromJSON (WorkflowGraphEdge fileid userid) where - parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do - wgeActors <- o JSON..: "actors" - wgeTarget <- o JSON..: "target" - wgeAutomatic <- o JSON..: "automatic" - wgeForm <- o JSON..: "form" - return WGE{..} + parseJSON = genericParseJSON workflowGraphEdgeAesonOptions instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid userid) where - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = JSON.object + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = JSON.object $ omitNothing [ "tag" JSON..= ("text" :: Text) , "label" JSON..= wpftLabel , "placeholder" JSON..= wpftPlaceholder @@ -294,7 +271,7 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us , "default" JSON..= wpftDefault , "optional" JSON..= wpftOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing [ "tag" JSON..= ("number" :: Text) , "label" JSON..= wpfnLabel , "placeholder" JSON..= wpfnPlaceholder @@ -305,137 +282,102 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us , "step" JSON..= wpfnStep , "optional" JSON..= wpfnOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing [ "tag" JSON..= ("bool" :: Text) , "label" JSON..= wpfbLabel , "tooltip" JSON..= wpfbTooltip , "default" JSON..= wpfbDefault + , "optional" JSON..= wpfbOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing [ "tag" JSON..= ("file" :: Text) , "label" JSON..= wpffLabel , "tooltip" JSON..= wpffTooltip , "default" JSON..= wpffDefault , "optional" JSON..= wpffOptional ] - toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing [ "tag" JSON..= ("user" :: Text) , "label" JSON..= wpfuLabel , "tooltip" JSON..= wpfuTooltip , "default" JSON..= wpfuDefault , "optional" JSON..= wpfuOptional ] -instance (FromJSON fileid, FromJSON userid - , Ord fileid, Ord userid + toJSON (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = JSON.object + [ "tag" JSON..= ("reference" :: Text) + , "target" JSON..= wpfrTarget + ] +instance ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid ) => FromJSON (WorkflowPayloadSpec fileid userid) where parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do fieldTag <- (o JSON..: "tag" :: Parser Text) case fieldTag of "text" -> do wpftLabel <- o JSON..: "label" - wpftPlaceholder <- o JSON..: "placeholder" + wpftPlaceholder <- o JSON..:? "placeholder" wpftTooltip <- o JSON..:? "tooltip" wpftDefault <- o JSON..:? "default" - wpftOptional <- o JSON..:? "optional" + wpftOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} "number" -> do wpfnLabel <- o JSON..: "label" - wpfnPlaceholder <- o JSON..: "placeholder" + wpfnPlaceholder <- o JSON..:? "placeholder" wpfnTooltip <- o JSON..:? "tooltip" wpfnDefault <- (o JSON..:? "default" :: Parser (Maybe Scientific)) wpfnMin <- o JSON..:? "min" wpfnMax <- o JSON..:? "max" wpfnStep <- o JSON..: "step" - wpfnOptional <- o JSON..:? "optional" + wpfnOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} "bool" -> do wpfbLabel <- o JSON..: "label" wpfbTooltip <- o JSON..:? "tooltip" - wpfbDefault <- (o JSON..:? "default" :: Parser (Maybe Bool)) + wpfbOptional <- o JSON..: "optional" + wpfbDefault <- (o JSON..: "default" :: Parser (Maybe Bool)) return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} "file" -> do wpffLabel <- o JSON..: "label" wpffTooltip <- o JSON..:? "tooltip" wpffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) - wpffOptional <- o JSON..:? "optional" + wpffOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} "user" -> do wpfuLabel <- o JSON..: "label" wpfuTooltip <- o JSON..:? "tooltip" wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) - wpfuOptional <- o JSON..:? "optional" + wpfuOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} + "reference" -> do + wpfrTarget <- o JSON..: "target" + return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} _ -> terror $ "WorkflowPayloadSpec parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag 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 - , Ord fileid, Ord userid + toJSON = genericToJSON workflowGraphNodeAesonOptions +instance ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable 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{..} - -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 + parseJSON = genericParseJSON workflowGraphNodeAesonOptions +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + } ''WorkflowInstanceScope deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 . fromJust . stripSuffix "'" } ''WorkflowInstanceScope' +deriveToJSON workflowActionAesonOptions ''WorkflowAction -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 ( FromJSON fileid, FromJSON userid + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid + ) => FromJSON (WorkflowAction fileid userid) where + parseJSON = genericParseJSON workflowActionAesonOptions instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object @@ -458,7 +400,7 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid [ "tag" JSON..= ("user" :: Text) , "user" JSON..= uid ] -instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where +instance (FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do fieldTag <- (o JSON..: "tag" :: Parser Text) case fieldTag of @@ -486,14 +428,16 @@ instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowFieldPayloadW f instance ( ToJSON fileid, ToJSON userid , FromJSON fileid, FromJSON userid , Ord fileid, Ord userid + , Typeable fileid, Typeable userid ) => PersistField (WorkflowGraph fileid userid) where toPersistValue = toPersistValueJSON fromPersistValue = fromPersistValueJSON instance ( ToJSON fileid, ToJSON userid , FromJSON fileid, FromJSON userid , Ord fileid, Ord userid + , Typeable fileid, Typeable userid ) => PersistFieldSql (WorkflowGraph fileid userid) where - sqlType _ = SqlString + sqlType _ = sqlTypeJSON instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid @@ -504,31 +448,20 @@ instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid , FromJSON termid, FromJSON schoolid, FromJSON courseid ) => PersistFieldSql (WorkflowInstanceScope termid schoolid courseid) where - sqlType _ = SqlString + sqlType _ = sqlTypeJSON derivePersistFieldJSON ''WorkflowInstanceScope' instance ( ToJSON fileid, ToJSON userid , FromJSON fileid, FromJSON userid - ) => PersistField (WorkflowPayload fileid userid) where + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid + ) => PersistField (WorkflowState 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, WorkflowRoleAuthorized $ PredDNF $ Set.fromList [impureNonNull $ Set.fromList [PLVariable AuthLecturer, PLNegated AuthParticipant]]]) (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 = "{\"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", WorkflowFieldPayloadW $ WFPText "hello world!"),("file-label", WorkflowFieldPayloadW $ WFPFile "fid"),("user-label", WorkflowFieldPayloadW $ WFPUser "uid")]) (Just "actor-user-id" :: Maybe Text) (UTCTime (ModifiedJulianDay 58946) 57250)))] - ---testPayloadStr :: Data.ByteString.Lazy.Internal.ByteString ---testPayloadStr = "{\"sometext\":[{\"action-time\":\"2020-04-07T15:54:10Z\",\"actor\":\"actor-user-id\",\"payload\":{\"user-label\":{\"tag\":\"user\",\"user\":\"uid\"},\"file-label\":{\"file\":\"fid\",\"tag\":\"file\"},\"text-label\":{\"text\":\"hello world!\",\"tag\":\"text\"}}}]}" + , Ord fileid, Ord userid + , Typeable fileid, Typeable userid + ) => PersistFieldSql (WorkflowState fileid userid) where + sqlType _ = sqlTypeJSON