diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 441a1e4a5..30c276140 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -4,10 +4,17 @@ import Import.NoModel import Model.Types.Security (AuthDNF) +import qualified Data.Set as Set (toList, fromList) +import qualified Data.Map as Map + +import qualified Data.Aeson as JSON +import Data.Aeson.Types (Parser) + data WorkflowRole userid = WorkflowRoleUser userid | WorkflowRoleAuthorized AuthDNF | WorkflowRoleInitiator userid + deriving (Eq, Ord, Show, Read, Generic, Typeable) data WorkflowGraphNodeStatus = WGNS @@ -20,6 +27,7 @@ data WorkflowGraphNodeStatus = WGNS data WorkflowGraphNode = WGN { wgnStatus :: WorkflowGraphNodeStatus } + deriving (Eq, Ord, Show, Read, Data, Generic, Typeable) type WorkflowGraphNodeLabel = CI Text @@ -48,8 +56,13 @@ data WorkflowEdgePayloadField fileid userid (payload :: *) where { wepfnLabel :: Text , wepfnPlaceholder :: Text , wepfnTooltip :: Maybe Text - , wepfnDefault :: Maybe prec + , wepfnDefault :: Maybe (Fixed prec) + , wepfnPrecision :: SomeResolution } -> WorkflowEdgePayloadField fileid userid (Fixed prec) + WorkflowEdgePayloadFieldBool :: { wepfbLabel :: Text + , wepfbTooltip :: Maybe Text + , wepfbDefault :: Maybe Bool + } -> WorkflowEdgePayloadField fileid userid Bool WorkflowEdgePayloadFieldFile :: { wepffLabel :: Text , wepffTooltip :: Maybe Text , wepffDefault :: Maybe fileid @@ -59,10 +72,27 @@ data WorkflowEdgePayloadField fileid userid (payload :: *) where , wepfuDefault :: Maybe userid } -> WorkflowEdgePayloadField fileid userid userid +instance forall fileid userid payload. (Eq fileid, Eq userid) => Eq (WorkflowEdgePayloadField fileid userid payload) where + (WorkflowEdgePayloadFieldText l1 p1 tt1 d1) == (WorkflowEdgePayloadFieldText l2 p2 tt2 d2) = l1 == l2 && p1 == p2 && tt1 == tt2 && d1 == d2 + (WorkflowEdgePayloadFieldNumber l1 p1 tt1 d1 prec1) == (WorkflowEdgePayloadFieldNumber l2 p2 tt2 d2 prec2) = l1 == l2 && p1 == p2 && tt1 == tt2 && d1 == d2 && prec1 == prec2 + (WorkflowEdgePayloadFieldBool l1 tt1 d1) == (WorkflowEdgePayloadFieldBool l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2 + (WorkflowEdgePayloadFieldFile l1 tt1 d1) == (WorkflowEdgePayloadFieldFile l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2 + (WorkflowEdgePayloadFieldUser l1 tt1 d1) == (WorkflowEdgePayloadFieldUser l2 tt2 d2) = l1 == l2 && tt1 == tt2 && d1 == d2 + _ == _ = False -data WorkflowEdgePayloadSpecification fileid userid = forall payload. (FromJSON payload, ToJSON payload) => WorkflowEdgePayloadSpecification (WorkflowEdgePayloadField fileid userid payload) +-- TODO remove this instance on removal of the test definition +instance forall fileid userid payload. (Ord fileid, Ord userid) => Ord (WorkflowEdgePayloadField fileid userid payload) where + compare _ _ = EQ +data WorkflowEdgePayloadSpecification fileid userid = forall payload. WorkflowEdgePayloadSpecification (WorkflowEdgePayloadField fileid userid payload) + +-- TODO remove (see above) +instance Eq (WorkflowEdgePayloadSpecification fileid userid) where + (WorkflowEdgePayloadSpecification _) == (WorkflowEdgePayloadSpecification _) = True +instance Ord (WorkflowEdgePayloadSpecification fileid userid) where + compare _ _ = EQ + data WorkflowPayload userid fileid = forall payload. Map WorkflowEdgePayloadLabel (WorkflowEdgePayload userid fileid payload) @@ -72,6 +102,12 @@ data WorkflowGraphEdge userid fileid = WGE , wgeForm :: Map WorkflowEdgePayloadLabel (NonNull (Set (WorkflowEdgePayloadSpecification fileid userid))) } +-- TODO remove (see above) +instance Eq (WorkflowGraphEdge userid fileid) where + _ == _ = True +instance Ord (WorkflowGraphEdge userid fileid) where + compare _ _ = EQ + data WorkflowGraph userid fileid = WorkflowGraph (Map WorkflowGraphNodeLabel (WorkflowGraphNode, Set (WorkflowGraphEdge userid fileid))) @@ -84,4 +120,139 @@ data WorkflowInstanceScope' = WISGlobal' | WISTerm' | WISSchool' | WISCourse' -deriveJSON defaultOptions ''WorkflowGraphNodeStatus +instance (ToJSON userid) => ToJSON (WorkflowRole userid) where + toJSON (WorkflowRoleUser uid) = JSON.object + [ "role" JSON..= ("user" :: Text) + , "user" JSON..= uid + ] + toJSON (WorkflowRoleAuthorized authDNF) = JSON.object + [ "role" JSON..= ("authorized" :: Text) + , "authorized" JSON..= authDNF + ] + toJSON (WorkflowRoleInitiator uid) = JSON.object + [ "role" JSON..= ("initiator" :: Text) + , "initiator" JSON..= uid + ] +instance (FromJSON userid) => FromJSON (WorkflowRole userid) where + parseJSON = JSON.withObject "WorkflowRole" $ \o -> do + role <- (o .: "role" :: Parser Text) + case role of + "user" -> do + uid <- o .: "user" + return $ WorkflowRoleUser uid + "authorized" -> do + adnf <- o .: "authorized" + return $ WorkflowRoleAuthorized adnf + "initiator" -> do + iid <- o .: "initiator" + return $ WorkflowRoleInitiator iid + _ -> do + (error.show) $ "WorkflowRole parseJSON error: expected role (user|authorized|initiator), but got " ++ role + +instance (ToJSON userid, ToJSON fileid) => ToJSON (WorkflowGraph userid fileid) where + toJSON (WorkflowGraph m) = toJSON m +instance (FromJSON userid, FromJSON fileid) => FromJSON (WorkflowGraph userid fileid) where + parseJSON = parseJSON + +instance (ToJSON userid, ToJSON fileid) => ToJSON (WorkflowGraphEdge userid fileid) where + toJSON (WGE{..}) = JSON.object + [ "actors" JSON..= Set.toList wgeActors + , "target" JSON..= wgeTarget + , "form" JSON..= wgeForm + ] +instance (FromJSON userid, Ord userid, FromJSON fileid) => FromJSON (WorkflowGraphEdge userid fileid) where + parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do + wgeActors <- o .: "actors" + wgeTarget <- o .: "target" + wgeForm <- o .: "form" + return WGE{..} + +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadSpecification fileid userid) where + toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldText{})) = toJSON f + toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldNumber{})) = toJSON f + toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldBool{})) = toJSON f + toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldFile{})) = toJSON f + toJSON (WorkflowEdgePayloadSpecification f@(WorkflowEdgePayloadFieldUser{})) = toJSON f +instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowEdgePayloadSpecification fileid userid) where + parseJSON = parseJSON -- TODO + +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid Text) where + toJSON (WorkflowEdgePayloadFieldText{..}) = JSON.object + [ "label" JSON..= wepftLabel + , "placeholder" JSON..= wepftPlaceholder + , "tooltip" JSON..= wepftTooltip + , "default" JSON..= wepftDefault + ] +instance (ToJSON fileid, ToJSON userid, HasResolution prec) => ToJSON (WorkflowEdgePayloadField fileid userid (Fixed prec)) where + toJSON (WorkflowEdgePayloadFieldNumber{..}) = JSON.object + [ "label" JSON..= wepfnLabel + , "placeholder" JSON..= wepfnPlaceholder + , "tooltip" JSON..= wepfnTooltip + , "default" JSON..= wepfnDefault + , "precision" JSON..= wepfnPrecision + ] +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid Bool) where + toJSON (WorkflowEdgePayloadFieldBool{..}) = JSON.object + [ "label" JSON..= wepfbLabel + , "tooltip" JSON..= wepfbTooltip + , "default" JSON..= wepfbDefault + ] +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid FileInfo) where + toJSON (WorkflowEdgePayloadFieldFile{..}) = JSON.object + [ "label" JSON..= wepffLabel + , "tooltip" JSON..= wepffTooltip + , "default" JSON..= wepffDefault + ] +instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowEdgePayloadField fileid userid userid) where + toJSON (WorkflowEdgePayloadFieldUser{..}) = JSON.object + [ "label" JSON..= wepfuLabel + , "tooltip" JSON..= wepfuTooltip + , "default" JSON..= wepfuDefault + ] + +instance (FromJSON fileid, FromJSON userid) => FromJSON (WorkflowEdgePayloadField fileid userid payload) where + parseJSON = JSON.withObject "WorkflowEdgePayloadField" $ \o -> do + fieldType <- (o JSON..: "type" :: Parser Text) + case fieldType of + "text" -> do + wepftLabel <- o JSON..: "label" + wepftPlaceholder <- o JSON..: "placeholder" + wepftTooltip <- o JSON..:? "tooltip" + wepftDefault <- o JSON..:? "default" + return (WorkflowEdgePayloadFieldText{..}) + "number" -> do + wepfnLabel <- o JSON..: "label" + wepfnPlaceholder <- o JSON..: "placeholder" + wepfnTooltip <- o JSON..:? "tooltip" + wepfnDefault <- (o JSON..:? "default" :: Parser (Maybe (Fixed prec))) + wepfnPrecision <- o JSON..: "precision" + return (WorkflowEdgePayloadFieldNumber{..}) + "bool" -> do + wepfbLabel <- o JSON..: "label" + wepfbTooltip <- o JSON..:? "tooltip" + wepfbDefault <- (o JSON..:? "default" :: Parser (Maybe Bool)) + return (WorkflowEdgePayloadFieldBool{..}) + "file" -> do + wepffLabel <- o JSON..: "label" + wepffTooltip <- o JSON..:? "tooltip" + wepffDefault <- (o JSON..:? "default" :: Parser (Maybe fileid)) + return (WorkflowEdgePayloadFieldFile{..}) + "user" -> do + wepfuLabel <- o JSON..: "label" + wepfuTooltip <- o JSON..:? "tooltip" + wepfuDefault <- (o JSON..:? "default" :: Parser (Maybe userid)) + return (WorkflowEdgePayloadFieldUser{..}) + _ -> error $ "WorkflowEdgePayloadField parseJSON error: expected field type (text|number|bool|file|user), but got " ++ fieldType + +instance ToJSON WorkflowGraphNode where + toJSON (WGN{..}) = toJSON wgnStatus +instance FromJSON WorkflowGraphNode where + parseJSON = parseJSON + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''WorkflowGraphNodeStatus + + +testGraph :: WorkflowGraph Text Text +testGraph = WorkflowGraph $ Map.fromList [("node1", (WGN (WGNS "id" True (Just "someLabel")), Set.fromList [WGE (Set.fromList [WorkflowRoleUser "user-id", WorkflowRoleInitiator "init-user-id"]) "node1" (Map.fromList [("sometext", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldText "text-label" "text-placeholder" (Just "text-tooltip") (Just "text-default")]),("someuser", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldUser "user-label" Nothing Nothing]),("somebool", impureNonNull $ Set.fromList [WorkflowEdgePayloadSpecification $ WorkflowEdgePayloadFieldBool "bool-label" Nothing (Just True)])])]))] diff --git a/src/Utils.hs b/src/Utils.hs index 4e0a169a5..ac55bfc69 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -333,6 +333,36 @@ stepTextCounter text fromText :: (IsString a, Textual t) => t -> a fromText = fromString . unpack + +----------- +-- Fixed -- +----------- + +rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a +rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy @a))) + +rationalToFixed3 :: Rational -> Fixed E3 +rationalToFixed3 = rationalToFixed + +rationalToFixed2 :: Rational -> Fixed E2 +rationalToFixed2 = rationalToFixed + +data SomeResolution = forall prec. HasResolution prec => SomeResolution (Proxy prec) + +instance Eq SomeResolution where + _ == _ = True +instance Ord SomeResolution where + compare _ _ = EQ + +instance FromJSON SomeResolution where + parseJSON = parseJSON +instance ToJSON SomeResolution where + toJSON = toJSON + +someResolutions :: [SomeResolution] +someResolutions = [ SomeResolution (Proxy @E0), SomeResolution (Proxy @E1), SomeResolution (Proxy @E2), SomeResolution (Proxy @E3) ] + + ---------- -- Bool -- ----------