From 4a34344c332291ceaed192ee1f0a73d97d855eeb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 21 Apr 2022 11:06:26 +0200 Subject: [PATCH] feat(workflows): additional text field types --- src/Handler/Utils/Workflow/EdgeForm.hs | 12 +++++++++++- src/Model/Types/Workflow.hs | 22 +++++++++++++++++++--- src/Utils/Form.hs | 20 ++++++++++++++++++-- 3 files changed, 48 insertions(+), 6 deletions(-) diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index 873f158c2..4bcaf8f92 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/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 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 29b7294c3..0eb666e38 100644 --- a/src/Model/Types/Workflow.hs +++ b/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" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5533b9977..a6b557274 100644 --- a/src/Utils/Form.hs +++ b/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 --