diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index 222416eaf..5d83eb826 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -75,6 +75,9 @@ WorkflowEdgeFormFieldUserNotFound: E-Mail Adresse konnte keinem/keiner Benutzer: WorkflowEdgeFormFieldMultipleNoneAdded: (Noch) keine Einträge WorkflowEdgeFormFieldCaptureUserLabel: Aktuelle:r Benutzer:in +WorkflowEdgeFormFieldDayTooFarPast offset@Integer: Datum liegt zu weit in der Vergangenheit (maximal #{offset} Tage) +WorkflowEdgeFormFieldDayTooFarFuture offset@Integer: Datum liegt zu weit in der Zukunft (maximal #{offset} Tage) + WorkflowEdgeFormFieldCaptureDateLabel: Aktuelles Datum WorkflowEdgeFormFieldCaptureTimeLabel: Aktuelle Uhrzeit WorkflowEdgeFormFieldCaptureDateTimeLabel: Aktuelles Datum/Zeit diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index c0241765a..aa8b5c391 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/messages/uniworx/categories/workflows/en-eu.msg @@ -34,6 +34,9 @@ WorkflowEdgeFormFieldUserNotFound: Email could not be resolved to an user WorkflowEdgeFormFieldMultipleNoneAdded: No entries (yet) WorkflowEdgeFormFieldCaptureUserLabel: Current user +WorkflowEdgeFormFieldDayTooFarPast offset: Date is too far in the past (maximum #{offset} days) +WorkflowEdgeFormFieldDayTooFarFuture offset: Date is too far in the future (maximum #{offset} days) + WorkflowEdgeFormFieldCaptureDateLabel: Current date WorkflowEdgeFormFieldCaptureTimeLabel: Current time WorkflowEdgeFormFieldCaptureDateTimeLabel: Current date/time diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index d4402ee97..19869b178 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -310,19 +310,20 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec extractPrev = extractPrevs $ \p -> \case Nothing -> Just p Just _ -> Nothing - 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' -> + delTyp :: forall payload' m. + ( State.MonadState [WorkflowFieldPayloadW FileReference UserId] m + , IsWorkflowFieldPayload' FileReference UserId payload' + ) => Proxy payload' -> m () + delTyp _ = State.modify $ \xs' -> let go [] = [] - go (x:xs) | is (_WorkflowFieldPayloadW @payload) x = xs + go (x:xs) | is (_WorkflowFieldPayloadW @payload') x = xs | otherwise = x : go xs in go xs' + 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)) + MsgRenderer mr <- getMsgRenderer LanguageSelectI18n{..} <- getLanguageSelectI18n @@ -366,10 +367,18 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec ) (prev <|> wpfbDefault) WorkflowPayloadFieldDay{..} -> do + cDay <- localDay . utcToLocalTime <$> liftIO getCurrentTime + let checkPast, checkFuture :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Day -> Field m Day + checkPast | Just offset <- wpfdMaxPast + = checkBool ((<= offset) . (cDay `diffDays`)) $ MsgWorkflowEdgeFormFieldDayTooFarPast offset + | otherwise = id + checkFuture | Just offset <- wpfdMaxFuture + = checkBool ((<= offset) . (`diffDays` cDay)) $ MsgWorkflowEdgeFormFieldDayTooFarFuture offset + | otherwise = id prev <- extractPrev @Day wSetTooltip' (fmap slI18n wpfdTooltip) $ f wpfdOptional - dayField + ( dayField & checkPast & checkFuture ) ( fsl (slI18n wpfdLabel) & maybe id (addName . ($ "day")) mNudge ) @@ -447,13 +456,13 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec t <- liftIO getCurrentTime case wpfcdtPrecision of WFCaptureDate -> do - delTyp + delTyp $ Proxy @Day (True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localDay $ utcToLocalTime t) <$ tell (All True) WFCaptureTime -> do - delTyp + delTyp $ Proxy @TimeOfDay (True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localTimeOfDay $ utcToLocalTime t) <$ tell (All True) WFCaptureDateTime -> do - delTyp + delTyp $ Proxy @UTCTime (True, FormSuccess . Just $ (_WorkflowFieldPayloadW . _WorkflowFieldPayload # t) :| []) <$ tell (All True) WorkflowPayloadFieldReference{..} -> throwE wpfrTarget WorkflowPayloadFieldMultiple{..} -> do diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index fe2723146..b1ada90b9 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -16,7 +16,7 @@ module Model.Types.Workflow , WorkflowPayloadView(..) , WorkflowPayloadSpec(..), _WorkflowPayloadSpec , WorkflowPayloadFieldReference - , WorkflowPayloadTimeCapturePrecision(..) + , WorkflowPayloadTimeCapture, WorkflowPayloadTimeCapturePrecision(..) , WorkflowPayloadField(..) , WorkflowScope(..) , WorkflowScope'(..), classifyWorkflowScope @@ -245,6 +245,9 @@ instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (Wo data WorkflowPayloadFieldReference deriving (Typeable) +data WorkflowPayloadTimeCapture + deriving (Typeable) + data WorkflowPayloadTimeCapturePrecision = WFCaptureDate | WFCaptureTime | WFCaptureDateTime deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -279,6 +282,7 @@ data WorkflowPayloadField fileid userid (payload :: Type) where , wpfdTooltip :: Maybe I18nHtml , wpfdDefault :: Maybe Day , wpfdOptional :: Bool + , wpfdMaxPast, wpfdMaxFuture :: Maybe Integer } -> WorkflowPayloadField fileid userid Day WorkflowPayloadFieldFile :: { wpffLabel :: I18nText , wpffTooltip :: Maybe I18nHtml @@ -294,7 +298,7 @@ data WorkflowPayloadField fileid userid (payload :: Type) where WorkflowPayloadFieldCaptureDateTime :: { wpfcdtPrecision :: WorkflowPayloadTimeCapturePrecision , wpfcdtLabel :: I18nText , wpfcdtTooltip :: Maybe I18nHtml - } -> WorkflowPayloadField fileid userid userid + } -> WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture WorkflowPayloadFieldReference :: { wpfrTarget :: WorkflowPayloadLabel } -> WorkflowPayloadField fileid userid WorkflowPayloadFieldReference WorkflowPayloadFieldMultiple :: { wpfmLabel :: I18nText @@ -373,7 +377,7 @@ instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (Wo WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` () WorkflowPayloadFieldNumber{..} -> wpfnLabel `deepseq` wpfnPlaceholder `deepseq` wpfnTooltip `deepseq` wpfnDefault `deepseq` wpfnMin `deepseq` wpfnMax `deepseq` wpfnStep `deepseq` wpfnOptional `deepseq` () WorkflowPayloadFieldBool{..} -> wpfbLabel `deepseq` wpfbTooltip `deepseq` wpfbDefault `deepseq` wpfbOptional `deepseq` () - WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` () + WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` wpfdMaxPast `deepseq` wpfdMaxFuture `deepseq` () WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` () WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` () WorkflowPayloadFieldCaptureUser -> () @@ -948,6 +952,8 @@ instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (Wo , "tooltip" JSON..= wpfdTooltip , "default" JSON..= wpfdDefault , "optional" JSON..= wpfdOptional + , "max-past" JSON..= wpfdMaxPast + , "max-future" JSON..= wpfdMaxFuture ] toJSON WorkflowPayloadFieldFile{..} = JSON.object $ omitNothing [ "tag" JSON..= WPFFile' @@ -1023,6 +1029,8 @@ instance ( FromJSON fileid, FromJSON userid wpfdTooltip <- o JSON..:? "tooltip" wpfdOptional <- o JSON..: "optional" wpfdDefault <- (o JSON..:? "default" :: Parser (Maybe Day)) + wpfdMaxPast <- o JSON..:? "max-past" + wpfdMaxFuture <- o JSON..:? "max-future" return $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..} WPFFile' -> do wpffLabel <- o JSON..: "label" diff --git a/test/Model/Types/WorkflowSpec.hs b/test/Model/Types/WorkflowSpec.hs index da81543a3..fca72b520 100644 --- a/test/Model/Types/WorkflowSpec.hs +++ b/test/Model/Types/WorkflowSpec.hs @@ -22,6 +22,8 @@ import Utils.I18n import qualified Data.CaseInsensitive as CI +import Data.Time.LocalTime (TimeOfDay) + instance Arbitrary WorkflowPayloadLabel where arbitrary = WorkflowPayloadLabel . CI.mk . pack <$> (fmap getPrintableString arbitrary `suchThat` (not . null)) @@ -35,6 +37,7 @@ instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Scientific) , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Bool) , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Day) + , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture) , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid (Set fileid)) , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid userid) , WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadFieldReference) @@ -71,6 +74,8 @@ instance Arbitrary (WorkflowPayloadField fileid userid Day) where <*> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary instance (Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadField fileid userid (Set fileid)) where arbitrary = WorkflowPayloadFieldFile <$> scale (`div` 2) arbitrary @@ -97,6 +102,15 @@ instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, <*> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary +instance Arbitrary (WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture) where + arbitrary = WorkflowPayloadFieldCaptureDateTime + <$> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary + <*> scale (`div` 2) arbitrary + +instance Arbitrary WorkflowPayloadTimeCapturePrecision where + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary WorkflowGraphEdgeFormOrder where arbitrary = genericArbitrary @@ -112,6 +126,8 @@ instance (Arbitrary fileid, Arbitrary userid, Ord fileid, Typeable userid, Typea , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Scientific) , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Bool) , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Day) + , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid TimeOfDay) + , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid UTCTime) , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid fileid) , WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid userid) ]