feat(workflows): restrict day field wrt. current time

Also fixes wrt. CaptureDateTime

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

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

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.
+          delTyp :: forall payload' m.
-                    ( MonadState [WorkflowFieldPayloadW FileReference UserId] m
+                    ( State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
-                    , IsWorkflowFieldPayload FileReference FileReference UserId UserId payload payload
+                    , IsWorkflowFieldPayload' FileReference UserId payload'
-                    ) => m ()
+                    ) => Proxy payload' -> m ()
-          delTyp = State.modify $ \xs' ->
+          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

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"

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)
     ]