From 5944a174bc8a749c60718b58d656f44cd21e7ecf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 9 Jun 2021 13:12:01 +0200 Subject: [PATCH] feat(workflows): new field CaptureDateTime --- .../categories/workflows/de-de-formal.msg | 4 + .../uniworx/categories/workflows/en-eu.msg | 6 +- src/Handler/Utils/Workflow/EdgeForm.hs | 44 +++++++ src/Handler/Workflow/Workflow/List.hs | 2 + src/Handler/Workflow/Workflow/Workflow.hs | 14 ++- src/Model/Types/Workflow.hs | 113 ++++++++++++++++-- 6 files changed, 167 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index 9d5156471..222416eaf 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -75,6 +75,10 @@ WorkflowEdgeFormFieldUserNotFound: E-Mail Adresse konnte keinem/keiner Benutzer: WorkflowEdgeFormFieldMultipleNoneAdded: (Noch) keine Einträge WorkflowEdgeFormFieldCaptureUserLabel: Aktuelle:r Benutzer:in +WorkflowEdgeFormFieldCaptureDateLabel: Aktuelles Datum +WorkflowEdgeFormFieldCaptureTimeLabel: Aktuelle Uhrzeit +WorkflowEdgeFormFieldCaptureDateTimeLabel: Aktuelles Datum/Zeit + WorkflowWorkflowWorkflowHistoryHeading: Verlauf WorkflowWorkflowWorkflowEdgeFormHeading: Aktion im Workflow auslösen WorkflowWorkflowWorkflowEdgeSuccess: Aktion erfolgreich ausgelöst diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index dacd9d738..c0241765a 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/messages/uniworx/categories/workflows/en-eu.msg @@ -34,6 +34,10 @@ WorkflowEdgeFormFieldUserNotFound: Email could not be resolved to an user WorkflowEdgeFormFieldMultipleNoneAdded: No entries (yet) WorkflowEdgeFormFieldCaptureUserLabel: Current user +WorkflowEdgeFormFieldCaptureDateLabel: Current date +WorkflowEdgeFormFieldCaptureTimeLabel: Current time +WorkflowEdgeFormFieldCaptureDateTimeLabel: Current date/time + WorkflowWorkflowWorkflowHistoryHeading: History WorkflowWorkflowWorkflowEdgeFormHeading: Trigger action within workflow WorkflowWorkflowWorkflowEdgeSuccess: Successfully triggered action @@ -137,4 +141,4 @@ YAMLFieldDecodeFailure yamlFailure: Could not parse YAML: #{yamlFailure} WGFTextInput: Text field WGFFileUpload: File field -WorkflowWorkflowListPersons: Involved users \ No newline at end of file +WorkflowWorkflowListPersons: Involved users diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index 020c1d7fd..d4402ee97 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -12,6 +12,7 @@ import Handler.Utils.Form import Handler.Utils.Workflow.CanonicalRoute import Handler.Utils.Widgets import Handler.Utils.Workflow.Restriction +import Handler.Utils.DateTime import qualified ListT @@ -312,6 +313,17 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec wSetTooltip' :: _ => Maybe Html -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a wSetTooltip' tip = hoist (hoist (wSetTooltip tip)) + delTyp :: forall m. + ( MonadState [WorkflowFieldPayloadW FileReference UserId] m + , IsWorkflowFieldPayload FileReference FileReference UserId UserId payload payload + ) => m () + delTyp = State.modify $ \xs' -> + let go [] = [] + go (x:xs) | is (_WorkflowFieldPayloadW @payload) x = xs + | otherwise = x : go xs + in go xs' + + MsgRenderer mr <- getMsgRenderer LanguageSelectI18n{..} <- getLanguageSelectI18n mNudge <- ask @@ -411,6 +423,38 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec } (True, FormSuccess . Just . (:| []) $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True) Nothing -> (False, FormMissing) <$ tell (All False) + WorkflowPayloadFieldCaptureDateTime{..} -> do + let + cLabel = case wpfcdtPrecision of + WFCaptureDate -> MsgWorkflowEdgeFormFieldCaptureDateLabel + WFCaptureTime -> MsgWorkflowEdgeFormFieldCaptureTimeLabel + WFCaptureDateTime -> MsgWorkflowEdgeFormFieldCaptureDateTimeLabel + + fvId <- newIdent + lift . lift . lift . tell $ pure FieldView + { fvLabel = Blaze.toMarkup $ slI18n wpfcdtLabel + , fvTooltip = slI18n <$> wpfcdtTooltip + , fvId + , fvInput = [whamlet| + $newline never + + _{cLabel} + |] + , fvErrors = Nothing + , fvRequired = False + } + + t <- liftIO getCurrentTime + case wpfcdtPrecision of + WFCaptureDate -> do + delTyp + (True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localDay $ utcToLocalTime t) <$ tell (All True) + WFCaptureTime -> do + delTyp + (True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localTimeOfDay $ utcToLocalTime t) <$ tell (All True) + WFCaptureDateTime -> do + delTyp + (True, FormSuccess . Just $ (_WorkflowFieldPayloadW . _WorkflowFieldPayload # t) :| []) <$ tell (All True) WorkflowPayloadFieldReference{..} -> throwE wpfrTarget WorkflowPayloadFieldMultiple{..} -> do fRefs <- nonEmpty <$> State.state (maybe (, []) (splitAt . fromIntegral) $ (+ wpfmMin) <$> wpfmRange) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index ae06a8083..22c50eb49 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -476,6 +476,8 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) + WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t) + WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t) WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True) WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . toJsonUser =<< lift (lift . lift $ getEntity uid) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index a0b024330..3a4248245 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -183,6 +183,8 @@ workflowR rScope cID = do WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) + WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t) + WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t) WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True) WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid) @@ -243,13 +245,15 @@ workflowR rScope cID = do

#{t} |] - WorkflowFieldPayloadW (WFPNumber n ) -> toWidget . toMarkup $ formatScientific Scientific.Fixed Nothing n - WorkflowFieldPayloadW (WFPBool b ) -> i18n $ WorkflowPayloadBool b - WorkflowFieldPayloadW (WFPDay d ) -> formatTimeW SelFormatDate d - WorkflowFieldPayloadW (WFPUser mUserEnt) -> case mUserEnt of + WorkflowFieldPayloadW (WFPNumber n ) -> toWidget . toMarkup $ formatScientific Scientific.Fixed Nothing n + WorkflowFieldPayloadW (WFPBool b ) -> i18n $ WorkflowPayloadBool b + WorkflowFieldPayloadW (WFPDay d ) -> formatTimeW SelFormatDate d + WorkflowFieldPayloadW (WFPTime t ) -> formatTimeW SelFormatTime t + WorkflowFieldPayloadW (WFPDateTime t ) -> formatTimeW SelFormatDateTime t + WorkflowFieldPayloadW (WFPUser mUserEnt) -> case mUserEnt of Nothing -> i18n MsgWorkflowPayloadUserGone Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname - WorkflowFieldPayloadW (WFPFile v ) -> absurd v + WorkflowFieldPayloadW (WFPFile v ) -> absurd v $(widgetFile "workflows/workflow") getWorkflowFilesR :: RouteWorkflowScope diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index ada4ef374..fe2723146 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -16,6 +16,7 @@ module Model.Types.Workflow , WorkflowPayloadView(..) , WorkflowPayloadSpec(..), _WorkflowPayloadSpec , WorkflowPayloadFieldReference + , WorkflowPayloadTimeCapturePrecision(..) , WorkflowPayloadField(..) , WorkflowScope(..) , WorkflowScope'(..), classifyWorkflowScope @@ -244,6 +245,13 @@ instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (Wo data WorkflowPayloadFieldReference deriving (Typeable) +data WorkflowPayloadTimeCapturePrecision + = WFCaptureDate | WFCaptureTime | WFCaptureDateTime + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) +instance Default WorkflowPayloadTimeCapturePrecision where + def = WFCaptureDateTime + -- Don't forget to update the NFData instance for every change! data WorkflowPayloadField fileid userid (payload :: Type) where WorkflowPayloadFieldText :: { wpftLabel :: I18nText @@ -283,6 +291,10 @@ data WorkflowPayloadField fileid userid (payload :: Type) where , wpfuOptional :: Bool } -> WorkflowPayloadField fileid userid userid WorkflowPayloadFieldCaptureUser :: WorkflowPayloadField fileid userid userid + WorkflowPayloadFieldCaptureDateTime :: { wpfcdtPrecision :: WorkflowPayloadTimeCapturePrecision + , wpfcdtLabel :: I18nText + , wpfcdtTooltip :: Maybe I18nHtml + } -> WorkflowPayloadField fileid userid userid WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel } -> WorkflowPayloadField fileid userid WorkflowPayloadFieldReference WorkflowPayloadFieldMultiple :: { wpfmLabel :: I18nText @@ -337,6 +349,14 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldFile{}) -> GT (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldUser{}) -> GT (WorkflowPayloadFieldCaptureUser{}, _) -> LT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldText{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldNumber{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldBool{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldDay{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldFile{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldUser{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, WorkflowPayloadFieldCaptureUser{}) -> GT + (WorkflowPayloadFieldCaptureDateTime{}, _) -> LT (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldText{}) -> GT (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldNumber{}) -> GT (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldBool{}) -> GT @@ -344,6 +364,7 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldFile{}) -> GT (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldUser{}) -> GT (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureUser{}) -> GT + (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureDateTime{}) -> GT (WorkflowPayloadFieldReference{}, _) -> LT (WorkflowPayloadFieldMultiple{}, _) -> GT @@ -356,6 +377,7 @@ instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (Wo WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` () WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` () WorkflowPayloadFieldCaptureUser -> () + WorkflowPayloadFieldCaptureDateTime{..} -> wpfcdtPrecision `deepseq` wpfcdtLabel `deepseq` wpfcdtTooltip `deepseq` () WorkflowPayloadFieldReference{..} -> wpfrTarget `deepseq` () WorkflowPayloadFieldMultiple{..} -> wpfmLabel `deepseq` wpfmTooltip `deepseq` wpfmDefault `deepseq` wpfmSub `deepseq` wpfmMin `deepseq` wpfmRange `deepseq` () @@ -364,7 +386,7 @@ _WorkflowPayloadSpec :: forall payload fileid userid. => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload) _WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> cast pF -data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple' +data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFCaptureDateTime' | WPFReference' | WPFMultiple' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) deriving anyclass (Universe, Finite, NFData) @@ -478,10 +500,23 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work (WFPDay{}, WFPNumber{}) -> GT (WFPDay{}, WFPBool{}) -> GT (WFPDay{}, _) -> LT + (WFPTime{}, WFPText{}) -> GT + (WFPTime{}, WFPNumber{}) -> GT + (WFPTime{}, WFPBool{}) -> GT + (WFPTime{}, WFPDay{}) -> GT + (WFPTime{}, _) -> LT + (WFPDateTime{}, WFPText{}) -> GT + (WFPDateTime{}, WFPNumber{}) -> GT + (WFPDateTime{}, WFPBool{}) -> GT + (WFPDateTime{}, WFPDay{}) -> GT + (WFPDateTime{}, WFPTime{}) -> GT + (WFPDateTime{}, _) -> LT (WFPFile{}, WFPText{}) -> GT (WFPFile{}, WFPNumber{}) -> GT (WFPFile{}, WFPBool{}) -> GT (WFPFile{}, WFPDay{}) -> GT + (WFPFile{}, WFPTime{}) -> GT + (WFPFile{}, WFPDateTime{}) -> GT (WFPFile{}, _) -> LT (WFPUser{}, _) -> GT @@ -506,11 +541,26 @@ workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPa (WFPDay{}, WFPNumber{} ) -> GT (WFPDay{}, WFPBool{} ) -> GT (WFPDay{}, _ ) -> LT + (WFPTime a', WFPTime b' ) -> compare a' b' + (WFPTime{}, WFPText{} ) -> GT + (WFPTime{}, WFPNumber{} ) -> GT + (WFPTime{}, WFPBool{} ) -> GT + (WFPTime{}, WFPDay{} ) -> GT + (WFPTime{}, _ ) -> LT + (WFPDateTime a', WFPDateTime b') -> compare a' b' + (WFPDateTime{}, WFPText{} ) -> GT + (WFPDateTime{}, WFPNumber{} ) -> GT + (WFPDateTime{}, WFPBool{} ) -> GT + (WFPDateTime{}, WFPDay{} ) -> GT + (WFPDateTime{}, WFPTime{} ) -> GT + (WFPDateTime{}, _ ) -> LT (WFPFile a', WFPFile b' ) -> ordFiles a' b' (WFPFile{}, WFPText{} ) -> GT (WFPFile{}, WFPNumber{} ) -> GT (WFPFile{}, WFPBool{} ) -> GT (WFPFile{}, WFPDay{} ) -> GT + (WFPFile{}, WFPTime{} ) -> GT + (WFPFile{}, WFPDateTime{}) -> GT (WFPFile{}, _ ) -> LT (WFPUser a', WFPUser b' ) -> ordUsers a' b' (WFPUser{}, _ ) -> GT @@ -524,6 +574,8 @@ data WorkflowFieldPayload fileid userid (payload :: Type) where WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific WFPBool :: Bool -> WorkflowFieldPayload fileid userid Bool WFPDay :: Day -> WorkflowFieldPayload fileid userid Day + WFPTime :: TimeOfDay -> WorkflowFieldPayload fileid userid TimeOfDay + WFPDateTime :: UTCTime -> WorkflowFieldPayload fileid userid UTCTime WFPFile :: fileid -> WorkflowFieldPayload fileid userid fileid WFPUser :: userid -> WorkflowFieldPayload fileid userid userid deriving (Typeable) @@ -534,19 +586,21 @@ deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayload fileid userid payload) where rnf = \case - WFPText t -> rnf t - WFPNumber n -> rnf n - WFPBool b -> rnf b - WFPDay d -> rnf d - WFPFile f -> rnf f - WFPUser u -> rnf u + WFPText t -> rnf t + WFPNumber n -> rnf n + WFPBool b -> rnf b + WFPDay d -> rnf d + WFPTime t -> rnf t + WFPDateTime t -> rnf t + WFPFile f -> rnf f + WFPUser u -> rnf u _WorkflowFieldPayloadW :: forall payload fileid userid. ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid ) => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload) _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW fp) -> cast fp -data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser' +data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPTime' | WFPDateTime' | WFPFile' | WFPUser' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) deriving anyclass (Universe, Finite, NFData, Binary) @@ -563,6 +617,10 @@ instance IsWorkflowFieldPayload fileid fileid userid userid Bool Bool where _WorkflowFieldPayload = prism' WFPBool $ \case { WFPBool x -> Just x; _other -> Nothing } instance IsWorkflowFieldPayload fileid fileid userid userid Day Day where _WorkflowFieldPayload = prism' WFPDay $ \case { WFPDay x -> Just x; _other -> Nothing } +instance IsWorkflowFieldPayload fileid fileid userid userid TimeOfDay TimeOfDay where + _WorkflowFieldPayload = prism' WFPTime $ \case { WFPTime x -> Just x; _other -> Nothing } +instance IsWorkflowFieldPayload fileid fileid userid userid UTCTime UTCTime where + _WorkflowFieldPayload = prism' WFPDateTime $ \case { WFPDateTime x -> Just x; _other -> Nothing } instance Typeable fileid => IsWorkflowFieldPayload fileid fileid' userid userid fileid fileid' where _WorkflowFieldPayload = prism WFPFile $ \case { WFPFile x -> Right x; other -> Left $ unsafeCoerce other } instance Typeable userid => IsWorkflowFieldPayload fileid fileid userid userid' userid userid' where @@ -677,6 +735,7 @@ instance (Typeable userid, Typeable fileid, Typeable fileid', Ord fileid', useri typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid') userid userid' where @@ -690,6 +749,7 @@ instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid') typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..} typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where @@ -739,6 +799,8 @@ nullaryPathPiece ''WorkflowPayloadField' $ camelToPathPiece' 1 . fromJust . stri derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--" +nullaryPathPiece ''WorkflowPayloadTimeCapturePrecision $ camelToPathPiece' 2 + ----- ToJSON / FromJSON instances ----- omitNothing :: [JSON.Pair] -> [JSON.Pair] @@ -762,6 +824,8 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 3 } ''WorkflowGraphRestriction +pathPieceJSON ''WorkflowPayloadTimeCapturePrecision + instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where parseJSON = genericParseJSON workflowNodeMessageAesonOptions instance (FromJSON userid, Ord userid) => FromJSON (WorkflowEdgeMessage userid) where @@ -902,6 +966,12 @@ instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (Wo toJSON WorkflowPayloadFieldCaptureUser{} = JSON.object [ "tag" JSON..= WPFCaptureUser' ] + toJSON WorkflowPayloadFieldCaptureDateTime{..} = JSON.object + [ "tag" JSON..= WPFCaptureDateTime' + , "label" JSON..= wpfcdtLabel + , "tooltip" JSON..= wpfcdtTooltip + , "precision" JSON..= wpfcdtPrecision + ] toJSON WorkflowPayloadFieldReference{..} = JSON.object [ "tag" JSON..= WPFReference' , "target" JSON..= wpfrTarget @@ -967,6 +1037,11 @@ instance ( FromJSON fileid, FromJSON userid wpfuOptional <- o JSON..: "optional" return $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} WPFCaptureUser' -> pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser + WPFCaptureDateTime' -> do + wpfcdtPrecision <- o JSON..:? "precision" JSON..!= def + wpfcdtLabel <- o JSON..: "label" + wpfcdtTooltip <- o JSON..:? "tooltip" + return $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureDateTime{..} WPFReference' -> do wpfrTarget <- o JSON..: "target" return $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} @@ -1040,6 +1115,14 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid [ "tag" JSON..= WFPDay' , toPathPiece WFPDay' JSON..= d ] + toJSON (WorkflowFieldPayloadW (WFPTime d)) = JSON.object + [ "tag" JSON..= WFPTime' + , toPathPiece WFPTime' JSON..= d + ] + toJSON (WorkflowFieldPayloadW (WFPDateTime t)) = JSON.object + [ "tag" JSON..= WFPDateTime' + , toPathPiece WFPDateTime' JSON..= t + ] toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object [ "tag" JSON..= WFPFile' , toPathPiece WFPFile' JSON..= fid @@ -1062,8 +1145,14 @@ instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeabl b <- o JSON..: toPathPiece WFPBool' return $ WorkflowFieldPayloadW $ WFPBool b WFPDay' -> do - b <- o JSON..: toPathPiece WFPDay' - return $ WorkflowFieldPayloadW $ WFPDay b + d <- o JSON..: toPathPiece WFPDay' + return $ WorkflowFieldPayloadW $ WFPDay d + WFPTime' -> do + t <- o JSON..: toPathPiece WFPTime' + return $ WorkflowFieldPayloadW $ WFPTime t + WFPDateTime' -> do + t <- o JSON..: toPathPiece WFPDateTime' + return $ WorkflowFieldPayloadW $ WFPDateTime t WFPFile' -> do fid <- o JSON..: toPathPiece WFPFile' return $ WorkflowFieldPayloadW $ WFPFile fid @@ -1137,6 +1226,8 @@ instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Bin WFPNumber' -> WorkflowFieldPayloadW . WFPNumber <$> Binary.get WFPBool' -> WorkflowFieldPayloadW . WFPBool <$> Binary.get WFPDay' -> WorkflowFieldPayloadW . WFPDay <$> Binary.get + WFPTime' -> WorkflowFieldPayloadW . WFPTime <$> Binary.get + WFPDateTime' -> WorkflowFieldPayloadW . WFPDateTime <$> Binary.get WFPFile' -> WorkflowFieldPayloadW . WFPFile <$> Binary.get WFPUser' -> WorkflowFieldPayloadW . WFPUser <$> Binary.get put = \case @@ -1144,6 +1235,8 @@ instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Bin WorkflowFieldPayloadW (WFPNumber n ) -> Binary.put WFPNumber' >> Binary.put n WorkflowFieldPayloadW (WFPBool b ) -> Binary.put WFPBool' >> Binary.put b WorkflowFieldPayloadW (WFPDay d ) -> Binary.put WFPDay' >> Binary.put d + WorkflowFieldPayloadW (WFPTime t ) -> Binary.put WFPTime' >> Binary.put t + WorkflowFieldPayloadW (WFPDateTime t) -> Binary.put WFPDateTime' >> Binary.put t WorkflowFieldPayloadW (WFPFile fid) -> Binary.put WFPFile' >> Binary.put fid WorkflowFieldPayloadW (WFPUser uid) -> Binary.put WFPUser' >> Binary.put uid