feat(workflows): restrict day field wrt. current time
Also fixes wrt. CaptureDateTime
This commit is contained in:
Gregor Kleen
parent
5944a174bc
commit
b742731511
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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)
|
||||
]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user