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

refactor(workflows): rework types & instances

Browse Source
This commit is contained in:
Gregor Kleen 2020-05-08 15:07:38 +02:00
parent c2169423e6
commit 8943c3e3bf
6 changed files with 271 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
models/workflows.model
View File

@ -1,20 +1,21 @@
WorkflowDefinition WorkflowDefinition
graph WorkflowGraph graph (WorkflowGraph SqlBackendKey SqlBackendKey)
scope WorkflowInstanceScope' scope WorkflowInstanceScope'
name (CI Text) name (CI Text)
UniqueWorkflowDefinition name scope UniqueWorkflowDefinition name scope
WorkflowInstance WorkflowInstance
definition WorkflowDefinition definition WorkflowDefinition
graph (WorkflowGraph Int64 Int64) -- FileId, UserId graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId
scope (WorkflowInstanceScope Int64 Int64 Int64) -- TermId, SchoolId, CourseId scope (WorkflowInstanceScope SqlBackendKey SqlBackendKey SqlBackendKey) -- TermId, SchoolId, CourseId
name (CI Text) name (CI Text)
category (CI Text) Maybe category (CI Text) Maybe
UniqueWorkflowInstance name scope UniqueWorkflowInstance name scope
WorkflowWorkflow WorkflowWorkflow
instance WorkflowInstance instance WorkflowInstance
graph WorkflowGraph graph (WorkflowGraph SqlBackendKey SqlBackendKey) -- FileId, UserId
initiator UserId Maybe initUser UserId Maybe
payload WorkflowPayload initTime UTCTime
currentNode WorkflowGraphNodeLabel Maybe state (WorkflowState SqlBackendKey SqlBackendKey) -- FileId, UserId
currentNode WorkflowGraphNodeLabel

2
src/Import/NoModel.hs
View File

@ -7,7 +7,7 @@ module Import.NoModel
import ClassyPrelude.Yesod as Import import ClassyPrelude.Yesod as Import
hiding ( formatTime hiding ( formatTime
, derivePersistFieldJSON , derivePersistFieldJSON, toPersistValueJSON, fromPersistValueJSON
, getMessages, addMessage, addMessageI , getMessages, addMessage, addMessageI
, (.=) , (.=)
, MForm , MForm

5
src/Model.hs
View File

@ -21,6 +21,11 @@ import Settings.Cluster (ClusterSettingsKey)
import Text.Blaze (ToMarkup(..)) 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 define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities

6
src/Model/Types/Security.hs
View File

@ -89,8 +89,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthDeprecated | AuthDeprecated
| AuthDevelopment | AuthDevelopment
| AuthFree | AuthFree
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable) deriving anyclass (Universe, Finite, Hashable, Binary)
nullaryPathPiece ''AuthTag $ camelToPathPiece' 1 nullaryPathPiece ''AuthTag $ camelToPathPiece' 1
pathPieceJSON ''AuthTag pathPieceJSON ''AuthTag
@ -149,7 +149,7 @@ instance PathPiece a => PathPiece (PredLiteral a) where
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) } 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 newtype (Semigroup, Monoid)
deriving anyclass (Binary, Hashable) deriving anyclass (Binary, Hashable)

55
src/Model/Types/TH/JSON.hs
View File

@ -1,11 +1,8 @@
module Model.Types.TH.JSON module Model.Types.TH.JSON where
( derivePersistFieldJSON
, predNFAesonOptions
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, toPersistValueJSON, fromPersistValueJSON)
import Data.List (foldl) 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.ByteString.Lazy as LBS
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
@ -18,6 +15,21 @@ import Language.Haskell.TH.Datatype
import Utils.PathPiece 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 :: Name -> DecsQ
derivePersistFieldJSON tName = do derivePersistFieldJSON tName = do
DatatypeInfo{..} <- reifyDatatype tName DatatypeInfo{..} <- reifyDatatype tName
@ -32,24 +44,15 @@ derivePersistFieldJSON tName = do
sequence sequence
[ instanceD iCxt ([t|PersistField|] `appT` t) [ instanceD iCxt ([t|PersistField|] `appT` t)
[ funD 'toPersistValue [ funD 'toPersistValue
[ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) [] [ clause [] (normalB [e|toPersistValueJSON|]) []
] ]
, funD 'fromPersistValue , funD 'fromPersistValue
[ do [ clause [] (normalB [e|fromPersistValueJSON|]) []
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"|]) []
] ]
] ]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD 'sqlType [ funD 'sqlType
[ clause [wildP] (normalB [e|SqlOther "jsonb"|]) [] [ clause [wildP] (normalB [e|sqlTypeJSON|]) []
] ]
] ]
] ]
@ -64,4 +67,20 @@ predNFAesonOptions = defaultOptions
, sumEncoding = ObjectWithSingleField , sumEncoding = ObjectWithSingleField
, tagSingleConstructors = True , 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
}

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

@ -3,29 +3,26 @@ module Model.Types.Workflow
, WorkflowGraphNodeLabel , WorkflowGraphNodeLabel
, WorkflowInstanceScope(..) , WorkflowInstanceScope(..)
, WorkflowInstanceScope'(..) , WorkflowInstanceScope'(..)
, WorkflowPayload(..) , WorkflowState
, WorkflowPayload'(..) , WorkflowAction(..)
) where ) where
import Import.NoModel import Import.NoModel
import Model.Types.Security (AuthDNF) import Model.Types.Security (AuthDNF)
--import Model.Types.Security (AuthDNF, PredDNF(..), AuthTag(..), PredLiteral(..))
import Database.Persist.Sql (PersistFieldSql(..)) 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.Scientific
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Aeson (genericToJSON, genericParseJSON)
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import Data.Aeson.Lens (_Null)
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
-- TODO remove import Type.Reflection (eqTypeRep, typeOf, (:~~:)(..))
--import Data.ByteString.Lazy.Internal (ByteString)
----- WORKFLOW GRAPH ----- ----- WORKFLOW GRAPH -----
@ -34,15 +31,17 @@ data WorkflowGraph fileid userid = WorkflowGraph
{ wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid) { wgNodes :: Map WorkflowGraphNodeLabel (WorkflowGraphNode fileid userid)
, wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowRole userid))) , wgPayloadViewers :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowRole userid)))
} }
deriving (Show, Eq) deriving (Eq, Ord, Show, Generic, Typeable)
----- WORKFLOW GRAPH: NODES ----- ----- WORKFLOW GRAPH: NODES -----
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel (CI Text) newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel (CI Text) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
deriving newtype (Eq, Ord, Show, Read, Typeable, 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 data WorkflowGraphNode fileid userid = WGN
{ wgnDisplayLabel :: Maybe Text { wgnDisplayLabel :: Maybe Text
@ -56,157 +55,166 @@ data WorkflowGraphNode fileid userid = WGN
----- WORKFLOW GRAPH: EDGES ----- ----- WORKFLOW GRAPH: EDGES -----
data WorkflowGraphEdge fileid userid = WGE data WorkflowGraphEdge fileid userid
{ wgeTarget :: WorkflowGraphNodeLabel = WorkflowGraphEdgeManual
, wgeAutomatic :: Bool { wgeTarget :: WorkflowGraphNodeLabel
, wgeActors :: Set (WorkflowRole userid) , wgeActors :: Set (WorkflowRole userid)
, wgeForm :: NonNull (Map WorkflowPayloadLabel (WorkflowPayloadSpec fileid userid)) , wgeForm :: Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec fileid userid)))
} -- ^ field requirement forms a cnf:
deriving Show --
-- - all labels must be filled
instance (Eq fileid, Eq userid) => Eq (WorkflowGraphEdge fileid userid) where -- - for each label any field must be filled
e1@WGE{} == e2@WGE{} = wgeTarget e1 == wgeTarget e2 && wgeActors e1 == wgeActors e2 && wgeForm e1 == wgeForm e2 -- - optional fields are always considered to be filled
--
instance (Ord fileid, Ord userid) => Ord (WorkflowGraphEdge fileid userid) where -- since fields can reference other labels this allows arbitrary requirements to be encoded.
compare = mconcat [comparing wgeTarget, comparing wgeActors, comparing wgeForm] }
| WorkflowGraphEdgeAutomatic
{ wgeTarget :: WorkflowGraphNodeLabel
}
deriving (Eq, Ord, Show, Generic, Typeable)
----- WORKFLOW GRAPH: ROLES / ACTORS ----- ----- WORKFLOW GRAPH: ROLES / ACTORS -----
data WorkflowRole userid data WorkflowRole userid
= WorkflowRoleUser userid = WorkflowRoleUser { workflowRoleUser :: userid }
| WorkflowRoleAuthorized AuthDNF | WorkflowRoleAuthorized { workflowRoleAuthorized :: AuthDNF }
| WorkflowRoleInitiator | WorkflowRoleInitiator
deriving (Eq, Ord, Show, Read, Generic, Typeable) deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
----- WORKFLOW GRAPH: PAYLOAD SPECIFICATION ----- ----- 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 deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadSpec fileid userid)
show (WorkflowPayloadSpec payloadField) = show payloadField
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 data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldText :: { wpftLabel :: Text WorkflowPayloadFieldText :: { wpftLabel :: Text
, wpftPlaceholder :: Text , wpftPlaceholder :: Maybe Text
, wpftTooltip :: Maybe Text , wpftTooltip :: Maybe Text
, wpftDefault :: Maybe Text , wpftDefault :: Maybe Text
, wpftOptional :: Maybe Bool , wpftOptional :: Bool
} -> WorkflowPayloadField fileid userid Text } -> WorkflowPayloadField fileid userid Text
WorkflowPayloadFieldNumber :: { wpfnLabel :: Text WorkflowPayloadFieldNumber :: { wpfnLabel :: Text
, wpfnPlaceholder :: Text , wpfnPlaceholder :: Maybe Text
, wpfnTooltip :: Maybe Text , wpfnTooltip :: Maybe Text
, wpfnDefault :: Maybe Scientific , wpfnDefault
, wpfnMin :: Maybe Scientific , wpfnMin
, wpfnMax :: Maybe Scientific , wpfnMax
, wpfnStep :: Scientific , wpfnStep :: Maybe Scientific
, wpfnOptional :: Maybe Bool , wpfnOptional :: Bool
} -> WorkflowPayloadField fileid userid Scientific } -> WorkflowPayloadField fileid userid Scientific
WorkflowPayloadFieldBool :: { wpfbLabel :: Text WorkflowPayloadFieldBool :: { wpfbLabel :: Text
, wpfbTooltip :: Maybe Text , wpfbTooltip :: Maybe Text
, wpfbDefault :: Maybe Bool , wpfbDefault :: Maybe Bool
} -> WorkflowPayloadField fileid userid Bool , wpfbOptional :: Maybe Text -- ^ Optional if `Just`; encodes label of `Nothing`-Option
WorkflowPayloadFieldFile :: { wpffLabel :: Text } -> WorkflowPayloadField fileid userid Bool
, wpffTooltip :: Maybe Text WorkflowPayloadFieldFile :: { wpffLabel :: Text
, wpffDefault :: Maybe fileid , wpffTooltip :: Maybe Text
, wpffOptional :: Maybe Bool , wpffDefault :: Maybe fileid
} -> WorkflowPayloadField fileid userid FileInfo , wpffOptional :: Bool
WorkflowPayloadFieldUser :: { wpfuLabel :: Text } -> WorkflowPayloadField fileid userid FileInfo
, wpfuTooltip :: Maybe Text WorkflowPayloadFieldUser :: { wpfuLabel :: Text
, wpfuDefault :: Maybe userid , wpfuTooltip :: Maybe Text
, wpfuOptional :: Maybe Bool , wpfuDefault :: Maybe userid
} -> WorkflowPayloadField fileid userid 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 deriving instance (Show fileid, Show userid) => Show (WorkflowPayloadField fileid userid payload)
show (WorkflowPayloadFieldText{..} ) = "TextField{label = " <> show wpftLabel deriving instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadField fileid userid payload)
<> ", placeholder = " <> show wpftPlaceholder deriving instance (Ord fileid, Ord userid) => Ord (WorkflowPayloadField fileid userid payload)
<> ", 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
<> "}"
instance (Eq fileid, Eq userid) => Eq (WorkflowPayloadSpec fileid userid) where instance (Eq fileid, Eq userid, Typeable fileid, Typeable 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 a) == (WorkflowPayloadSpec b)
(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 = case typeOf a `eqTypeRep` typeOf b of
(WorkflowPayloadSpec f1@WorkflowPayloadFieldBool{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldBool{}) = wpfbLabel f1 == wpfbLabel f2 && wpfbTooltip f1 == wpfbTooltip f2 && wpfbDefault f1 == wpfbDefault f2 Just HRefl -> a == b
(WorkflowPayloadSpec f1@WorkflowPayloadFieldFile{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldFile{}) = wpffLabel f1 == wpffLabel f2 && wpffTooltip f1 == wpffTooltip f2 && wpffDefault f1 == wpffDefault f2 && wpffOptional f1 == wpffOptional f2 Nothing -> False
(WorkflowPayloadSpec f1@WorkflowPayloadFieldUser{}) == (WorkflowPayloadSpec f2@WorkflowPayloadFieldUser{}) = wpfuLabel f1 == wpfuLabel f2 && wpfuTooltip f1 == wpfuTooltip f2 && wpfuDefault f1 == wpfuDefault f2 && wpfuOptional f1 == wpfuOptional f2
_ == _ = False
instance (Ord fileid, Ord userid) => Ord (WorkflowPayloadSpec fileid userid) where instance (Ord fileid, Ord userid, Typeable fileid, Typeable 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 (WorkflowPayloadSpec a) `compare` (WorkflowPayloadSpec b)
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 = case typeOf a `eqTypeRep` typeOf b of
compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldBool{}) = mconcat [comparing wpfbLabel, comparing wpfbTooltip, comparing wpfbDefault] f1 f2 Just HRefl -> a `compare` b
compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldFile{}) = mconcat [comparing wpffLabel, comparing wpffTooltip, comparing wpffDefault, comparing wpffOptional] f1 f2 Nothing -> case (a, b) of
compare (WorkflowPayloadSpec f1@WorkflowPayloadFieldUser{}) (WorkflowPayloadSpec f2@WorkflowPayloadFieldUser{}) = mconcat [comparing wpfuLabel, comparing wpfuTooltip, comparing wpfuDefault, comparing wpfuOptional] f1 f2 (WorkflowPayloadFieldText{}, _) -> LT
compare (WorkflowPayloadSpec WorkflowPayloadFieldText{} ) _ = LT (WorkflowPayloadFieldNumber{}, WorkflowPayloadFieldText{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT (WorkflowPayloadFieldNumber{}, _) -> LT
compare (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) _ = LT (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldText{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldNumber{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) = GT (WorkflowPayloadFieldBool{}, _) -> LT
compare (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) _ = LT (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldText{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldText{}) = GT (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldNumber{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldNumber{}) = GT (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldBool{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) (WorkflowPayloadSpec WorkflowPayloadFieldBool{}) = GT (WorkflowPayloadFieldFile{}, _) -> LT
compare (WorkflowPayloadSpec WorkflowPayloadFieldFile{}) _ = LT (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldText{}) -> GT
compare (WorkflowPayloadSpec WorkflowPayloadFieldUser{}) _ = LT (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldNumber{}) -> GT
(WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT
(WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT
(WorkflowPayloadFieldUser{}, _) -> LT
(WorkflowPayloadFieldReference{}, _) -> GT
----- WORKFLOW INSTANCE ----- ----- WORKFLOW INSTANCE -----
data WorkflowInstanceScope termid schoolid courseid data WorkflowInstanceScope termid schoolid courseid
= WISGlobal = WISGlobal
| WISTerm termid | WISTerm { wisTerm :: termid }
| WISSchool schoolid | WISSchool { wisSchool :: schoolid }
| WISCourse courseid | WISCourse { wisCourse :: courseid }
deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
data WorkflowInstanceScope' = WISGlobal' | WISTerm' | WISSchool' | WISCourse' data WorkflowInstanceScope'
deriving (Eq, Ord, Enum, Read, Show, Data, Generic, Typeable) = WISGlobal' | WISTerm' | WISSchool' | WISCourse'
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
deriving anyclass (Universe, Finite)
----- WORKFLOW: PAYLOAD ----- ----- WORKFLOW: PAYLOAD -----
newtype WorkflowPayloadLabel = WorkflowPayloadLabel (CI Text) newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text }
deriving newtype (Eq, Ord, Show, Read, Typeable, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql) 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' data WorkflowAction fileid userid = WorkflowAction
{ wpPayload :: Map WorkflowGraphNodeLabel (Map WorkflowGraphEdgeLabel (Map WorkflowPayloadFieldLabel (WorkflowFieldPayloadW fileid userid))) { wpFrom :: WorkflowGraphNodeLabel
, wpActor :: Maybe userid , wpVia :: WorkflowGraphEdgeLabel
, wpActionTime :: UTCTime , 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 instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
show (WorkflowFieldPayloadW payload) = show payload show (WorkflowFieldPayloadW payload) = show payload
@ -217,76 +225,45 @@ data WorkflowFieldPayload fileid userid (payload :: Type) where
WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool
WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid
WFPUser :: userid -> WorkflowFieldPayload fileid userid userid WFPUser :: userid -> WorkflowFieldPayload fileid userid userid
deriving (Typeable)
instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload) where deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload)
show (WFPText wfptText ) = "WFPText{text = " <> show wfptText <> "}" deriving instance (Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload)
show (WFPNumber wfpnNumber) = "WFPNumber{number = " <> show wfpnNumber <> "}" deriving instance (Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload)
show (WFPBool wfpbBool ) = "WFPBool{bool = " <> show wfpbBool <> "}"
show (WFPFile wfpfFile ) = "WFPFile{file = " <> show wfpfFile <> "}"
show (WFPUser wfpuUser ) = "WFPUser{user = " <> show wfpuUser <> "}"
data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPUser' 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 ----- ----- ToJSON / FromJSON instances -----
instance (ToJSON userid) => ToJSON (WorkflowRole userid) where omitNothing :: [JSON.Pair] -> [JSON.Pair]
toJSON (WorkflowRoleUser uid) = JSON.object omitNothing = filter . hasn't $ _2 . _Null
[ "tag" JSON..= ("user" :: Text)
, "user" JSON..= uid deriveJSON defaultOptions
] { fieldLabelModifier = camelToPathPiece' 2
toJSON (WorkflowRoleAuthorized authDNF) = JSON.object , constructorTagModifier = camelToPathPiece' 2
[ "tag" JSON..= ("authorized" :: Text) } ''WorkflowRole
, "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
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraph fileid userid) where
toJSON WorkflowGraph{..} = JSON.object toJSON = genericToJSON workflowGraphAesonOptions
[ "nodes" JSON..= wgNodes instance ( FromJSON fileid, FromJSON userid
, "payload-viewers" JSON..= wgPayloadViewers , Ord fileid, Ord userid
] , Typeable fileid, Typeable userid
instance (FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid
) => FromJSON (WorkflowGraph fileid userid) where ) => FromJSON (WorkflowGraph fileid userid) where
parseJSON = JSON.withObject "WorkflowGraph" $ \o -> do parseJSON = genericParseJSON workflowGraphAesonOptions
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 instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphEdge fileid userid) where
toJSON (WGE{..}) = JSON.object toJSON = genericToJSON workflowGraphEdgeAesonOptions
[ "actors" JSON..= Set.toList wgeActors instance ( FromJSON fileid, FromJSON userid
, "target" JSON..= wgeTarget , Ord fileid, Ord userid
, "form" JSON..= wgeForm , Typeable fileid, Typeable userid
]
instance (FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid
) => FromJSON (WorkflowGraphEdge fileid userid) where ) => FromJSON (WorkflowGraphEdge fileid userid) where
parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do parseJSON = genericParseJSON workflowGraphEdgeAesonOptions
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 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) [ "tag" JSON..= ("text" :: Text)
, "label" JSON..= wpftLabel , "label" JSON..= wpftLabel
, "placeholder" JSON..= wpftPlaceholder , "placeholder" JSON..= wpftPlaceholder
@ -294,7 +271,7 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us
, "default" JSON..= wpftDefault , "default" JSON..= wpftDefault
, "optional" JSON..= wpftOptional , "optional" JSON..= wpftOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object toJSON (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("number" :: Text) [ "tag" JSON..= ("number" :: Text)
, "label" JSON..= wpfnLabel , "label" JSON..= wpfnLabel
, "placeholder" JSON..= wpfnPlaceholder , "placeholder" JSON..= wpfnPlaceholder
@ -305,137 +282,102 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayloadSpec fileid us
, "step" JSON..= wpfnStep , "step" JSON..= wpfnStep
, "optional" JSON..= wpfnOptional , "optional" JSON..= wpfnOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object toJSON (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("bool" :: Text) [ "tag" JSON..= ("bool" :: Text)
, "label" JSON..= wpfbLabel , "label" JSON..= wpfbLabel
, "tooltip" JSON..= wpfbTooltip , "tooltip" JSON..= wpfbTooltip
, "default" JSON..= wpfbDefault , "default" JSON..= wpfbDefault
, "optional" JSON..= wpfbOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object toJSON (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("file" :: Text) [ "tag" JSON..= ("file" :: Text)
, "label" JSON..= wpffLabel , "label" JSON..= wpffLabel
, "tooltip" JSON..= wpffTooltip , "tooltip" JSON..= wpffTooltip
, "default" JSON..= wpffDefault , "default" JSON..= wpffDefault
, "optional" JSON..= wpffOptional , "optional" JSON..= wpffOptional
] ]
toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object toJSON (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = JSON.object $ omitNothing
[ "tag" JSON..= ("user" :: Text) [ "tag" JSON..= ("user" :: Text)
, "label" JSON..= wpfuLabel , "label" JSON..= wpfuLabel
, "tooltip" JSON..= wpfuTooltip , "tooltip" JSON..= wpfuTooltip
, "default" JSON..= wpfuDefault , "default" JSON..= wpfuDefault
, "optional" JSON..= wpfuOptional , "optional" JSON..= wpfuOptional
] ]
instance (FromJSON fileid, FromJSON userid toJSON (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = JSON.object
, Ord fileid, Ord userid [ "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 ) => FromJSON (WorkflowPayloadSpec fileid userid) where
parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do parseJSON = JSON.withObject "WorkflowPayloadSpec" $ \o -> do
fieldTag <- (o JSON..: "tag" :: Parser Text) fieldTag <- (o JSON..: "tag" :: Parser Text)
case fieldTag of case fieldTag of
"text" -> do "text" -> do
wpftLabel <- o JSON..: "label" wpftLabel <- o JSON..: "label"
wpftPlaceholder <- o JSON..: "placeholder" wpftPlaceholder <- o JSON..:? "placeholder"
wpftTooltip <- o JSON..:? "tooltip" wpftTooltip <- o JSON..:? "tooltip"
wpftDefault <- o JSON..:? "default" wpftDefault <- o JSON..:? "default"
wpftOptional <- o JSON..:? "optional" wpftOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
"number" -> do "number" -> do
wpfnLabel <- o JSON..: "label" wpfnLabel <- o JSON..: "label"
wpfnPlaceholder <- o JSON..: "placeholder" wpfnPlaceholder <- o JSON..:? "placeholder"
wpfnTooltip <- o JSON..:? "tooltip" wpfnTooltip <- o JSON..:? "tooltip"
wpfnDefault <- (o JSON..:? "default" :: Parser (Maybe Scientific)) wpfnDefault <- (o JSON..:? "default" :: Parser (Maybe Scientific))
wpfnMin <- o JSON..:? "min" wpfnMin <- o JSON..:? "min"
wpfnMax <- o JSON..:? "max" wpfnMax <- o JSON..:? "max"
wpfnStep <- o JSON..: "step" wpfnStep <- o JSON..: "step"
wpfnOptional <- o JSON..:? "optional" wpfnOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
"bool" -> do "bool" -> do
wpfbLabel <- o JSON..: "label" wpfbLabel <- o JSON..: "label"
wpfbTooltip <- o JSON..:? "tooltip" 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{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
"file" -> do "file" -> do
wpffLabel <- o JSON..: "label" wpffLabel <- o JSON..: "label"
wpffTooltip <- o JSON..:? "tooltip" wpffTooltip <- o JSON..:? "tooltip"
wpffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) wpffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid))
wpffOptional <- o JSON..:? "optional" wpffOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} return $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
"user" -> do "user" -> do
wpfuLabel <- o JSON..: "label" wpfuLabel <- o JSON..: "label"
wpfuTooltip <- o JSON..:? "tooltip" wpfuTooltip <- o JSON..:? "tooltip"
wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) wpfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid))
wpfuOptional <- o JSON..:? "optional" wpfuOptional <- o JSON..: "optional"
return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} 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 _ -> 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 instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowGraphNode fileid userid) where
toJSON WGN{..} = JSON.object toJSON = genericToJSON workflowGraphNodeAesonOptions
[ "display-label" JSON..= wgnDisplayLabel instance ( FromJSON fileid, FromJSON userid
, "initial" JSON..= wgnInitial , Ord fileid, Ord userid
, "finished" JSON..= wgnFinished , Typeable fileid, Typeable userid
, "viewers" JSON..= wgnViewers
, "edges" JSON..= wgnEdges
]
instance (FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid
) => FromJSON (WorkflowGraphNode fileid userid) where ) => FromJSON (WorkflowGraphNode fileid userid) where
parseJSON = JSON.withObject "WorkflowGraphNode" $ \o -> do parseJSON = genericParseJSON workflowGraphNodeAesonOptions
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
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
} ''WorkflowInstanceScope
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 . fromJust . stripSuffix "'" { constructorTagModifier = camelToPathPiece' 1 . fromJust . stripSuffix "'"
} ''WorkflowInstanceScope' } ''WorkflowInstanceScope'
deriveToJSON workflowActionAesonOptions ''WorkflowAction
instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowPayload' fileid userid) where instance ( FromJSON fileid, FromJSON userid
toJSON WorkflowPayload'{..} = JSON.object , Ord fileid, Ord userid
[ "payload" JSON..= wpPayload , Typeable fileid, Typeable userid
, "actor" JSON..= wpActor ) => FromJSON (WorkflowAction fileid userid) where
, "action-time" JSON..= wpActionTime parseJSON = genericParseJSON workflowActionAesonOptions
]
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 instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where
toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object
@ -458,7 +400,7 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid
[ "tag" JSON..= ("user" :: Text) [ "tag" JSON..= ("user" :: Text)
, "user" JSON..= uid , "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 parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do
fieldTag <- (o JSON..: "tag" :: Parser Text) fieldTag <- (o JSON..: "tag" :: Parser Text)
case fieldTag of case fieldTag of
@ -486,14 +428,16 @@ instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowFieldPayloadW f
instance ( ToJSON fileid, ToJSON userid instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON userid , FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid
) => PersistField (WorkflowGraph fileid userid) where ) => PersistField (WorkflowGraph fileid userid) where
toPersistValue = toPersistValueJSON toPersistValue = toPersistValueJSON
fromPersistValue = fromPersistValueJSON fromPersistValue = fromPersistValueJSON
instance ( ToJSON fileid, ToJSON userid instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON userid , FromJSON fileid, FromJSON userid
, Ord fileid, Ord userid , Ord fileid, Ord userid
, Typeable fileid, Typeable userid
) => PersistFieldSql (WorkflowGraph fileid userid) where ) => PersistFieldSql (WorkflowGraph fileid userid) where
sqlType _ = SqlString sqlType _ = sqlTypeJSON
instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid 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 instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid
, FromJSON termid, FromJSON schoolid, FromJSON courseid , FromJSON termid, FromJSON schoolid, FromJSON courseid
) => PersistFieldSql (WorkflowInstanceScope termid schoolid courseid) where ) => PersistFieldSql (WorkflowInstanceScope termid schoolid courseid) where
sqlType _ = SqlString sqlType _ = sqlTypeJSON
derivePersistFieldJSON ''WorkflowInstanceScope' derivePersistFieldJSON ''WorkflowInstanceScope'
instance ( ToJSON fileid, ToJSON userid instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON 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 toPersistValue = toPersistValueJSON
fromPersistValue = fromPersistValueJSON fromPersistValue = fromPersistValueJSON
instance ( ToJSON fileid, ToJSON userid instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON userid , FromJSON fileid, FromJSON userid
) => PersistFieldSql (WorkflowPayload fileid userid) where , Ord fileid, Ord userid
sqlType _ = SqlString , Typeable fileid, Typeable userid
) => PersistFieldSql (WorkflowState fileid userid) where
sqlType _ = sqlTypeJSON
----- 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\"}}}]}"