feat(workflows): additional text field types

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -332,12 +332,22 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
       case specField of
         WorkflowPayloadFieldText{..} | Nothing <- wpftPresets -> do
           prev <- extractPrev @Text
+          let field = case wpftType of
+                WorkflowPayloadTextTypeText -> textField & cfStrip
+                WorkflowPayloadTextTypeLarge -> textareaField & isoField _Wrapped & cfStrip
+                WorkflowPayloadTextTypeEmail -> emailField
+                WorkflowPayloadTextTypeUrl -> urlFieldText
+                WorkflowPayloadTextTypePassword -> passwordField
+              addFieldSettings = case wpftType of
+                WorkflowPayloadTextTypePassword -> addAttr "autofill" "new-password"
+                _other -> id
           wSetTooltip' (fmap slI18n wpftTooltip) $
             f wpftOptional
-              (bool (textField & cfStrip) (textareaField & isoField _Wrapped & cfStrip) wpftLarge)
+              field
               ( fsl (slI18n wpftLabel)
                   & maybe id (addPlaceholder . slI18n) wpftPlaceholder
                   & maybe id (addName . ($ "text")) mNudge
+                  & addFieldSettings
               )
               (prev <|> wpftDefault)
         WorkflowPayloadFieldText{..} | Just (otoList -> opts) <- wpftPresets -> do

src/Model/Types/Workflow.hs

@@ -18,6 +18,7 @@ module Model.Types.Workflow
   , WorkflowPayloadFieldReference
   , WorkflowPayloadTimeCapture, WorkflowPayloadTimeCapturePrecision(..)
   , WorkflowPayloadTextPreset(..)
+  , WorkflowPayloadTextType(..)
   , WorkflowPayloadField(..)
   , WorkflowScope(..)
   , WorkflowScope'(..), classifyWorkflowScope
@@ -263,15 +264,24 @@ data WorkflowPayloadTextPreset = WorkflowPayloadTextPreset
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
     deriving anyclass (NFData)
 
+data WorkflowPayloadTextType
+  = WorkflowPayloadTextTypeText
+  | WorkflowPayloadTextTypeLarge
+  | WorkflowPayloadTextTypeEmail
+  | WorkflowPayloadTextTypeUrl
+  | WorkflowPayloadTextTypePassword
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite, NFData)
+
 -- Don't forget to update the NFData instance for every change!
 data WorkflowPayloadField fileid userid (payload :: Type) where
   WorkflowPayloadFieldText      :: { wpftLabel       :: I18nText
                                    , wpftPlaceholder :: Maybe I18nText
                                    , wpftTooltip     :: Maybe I18nHtml
                                    , wpftDefault     :: Maybe Text
-                                   , wpftLarge       :: Bool
                                    , wpftOptional    :: Bool
                                    , wpftPresets     :: Maybe (NonEmpty WorkflowPayloadTextPreset)
+                                   , wpftType        :: WorkflowPayloadTextType
                                    } -> WorkflowPayloadField fileid userid Text
   WorkflowPayloadFieldNumber    :: { wpfnLabel       :: I18nText
                                    , wpfnPlaceholder :: Maybe I18nText
@@ -383,7 +393,7 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie
 
 instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadField fileid userid payload) where
   rnf = \case
-    WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` wpftPresets `deepseq` ()
+    WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftOptional `deepseq` wpftPresets `deepseq` wpftType `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` wpfdMaxPast `deepseq` wpfdMaxFuture `deepseq` ()
@@ -843,6 +853,11 @@ deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   } ''WorkflowPayloadTextPreset
 
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 4
+  , allNullaryToStringTag = True
+  } ''WorkflowPayloadTextType
+
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where
   parseJSON = genericParseJSON workflowNodeMessageAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowEdgeMessage userid) where
@@ -938,9 +953,9 @@ instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (Wo
     , "placeholder" JSON..=  wpftPlaceholder
     , "tooltip"     JSON..=  wpftTooltip
     , "default"     JSON..=  wpftDefault
-    , "large"       JSON..=  wpftLarge
     , "optional"    JSON..=  wpftOptional
     , "presets"     JSON..=  wpftPresets
+    , "type"        JSON..=  wpftType
     ]
   toJSON WorkflowPayloadFieldNumber{..} = JSON.object $ omitNothing
     [ "tag"         JSON..=  WPFNumber'
@@ -1022,6 +1037,7 @@ instance ( FromJSON fileid, FromJSON userid
         wpftLarge       <-  o JSON..:? "large" JSON..!= False
         wpftOptional    <-  o JSON..:  "optional"
         wpftPresets     <-  o JSON..:? "presets"
+        wpftType        <-  o JSON..:? "type" JSON..!= bool WorkflowPayloadTextTypeText WorkflowPayloadTextTypeLarge wpftLarge
         return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
       WPFNumber' -> do
         wpfnLabel       <-  o JSON..:  "label"

src/Utils/Form.hs

@@ -46,7 +46,7 @@ import Data.List (nub, (!!))
 
 import Web.PathPieces
 
-import Data.UUID
+import Data.UUID hiding (toText)
 
 import Data.Ratio ((%))
 import Data.Fixed
@@ -924,12 +924,28 @@ data UrlFieldMessage = UrlFieldCouldNotParseAbsolute
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
+urlField' :: ( Monad m
+             , RenderMessage (HandlerSite m) UrlFieldMessage
+             , RenderMessage (HandlerSite m) FormMessage
+             )
+          => (URI -> a) -> (a -> Text)
+          -> Field m a
+urlField' fromURI toText = checkMap (maybe (Left UrlFieldCouldNotParseAbsolute) (Right . fromURI) . parseURI . unpack) toText Yesod.urlField
+
 urlField :: ( Monad m
             , RenderMessage (HandlerSite m) UrlFieldMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => Field m URI
-urlField = checkMap (maybe (Left UrlFieldCouldNotParseAbsolute) Right . parseURI . unpack) (pack . ($ mempty) . uriToString id) Yesod.urlField
+urlField = urlField' id $ pack . ($ mempty) . uriToString id
+
+urlFieldText :: ( Monad m
+                , RenderMessage (HandlerSite m) UrlFieldMessage
+                , RenderMessage (HandlerSite m) FormMessage
+                )
+             => Field m Text
+urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id
+ 
 
 -----------
 -- Forms --