From 01ab73a32c7ba544258c94c029a3511d42c459c9 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sat, 1 Oct 2022 15:56:37 +0200 Subject: [PATCH] Allow formFor with GET method Fixes #1536 --- Guide/form.markdown | 21 ++++++++++ IHP/View/Form.hs | 23 +++++++---- IHP/View/Types.hs | 2 + Test/Main.hs | 2 + Test/View/FormSpec.hs | 96 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 136 insertions(+), 8 deletions(-) create mode 100644 Test/View/FormSpec.hs diff --git a/Guide/form.markdown b/Guide/form.markdown index 4a812538f..e5303b68b 100644 --- a/Guide/form.markdown +++ b/Guide/form.markdown @@ -793,6 +793,27 @@ The generated HTML will look like this:
``` +### GET Forms / Custom Form Method + +By default forms use `method="POST"`. You can submit your form using the `GET` request method by overriding [`formMethod`](https://ihp.digitallyinduced.com/api-docs/IHP-View-Form.html#v:formMethod): + +```haskell +renderForm :: Post -> Html +renderForm post = formForWithOptions post options [hsx||] + +options :: FormContext Post -> FormContext Post +options formContext = + formContext + |> set #formMethod "GET" +``` + +The generated HTML will look like this: + +```html + +``` + + ### Disable Form Submission via JavaScript Your form will be submitted using AJAX and TurboLinks instead of browser-based form submission. diff --git a/IHP/View/Form.hs b/IHP/View/Form.hs index 3cbd97f83..acbadb470 100644 --- a/IHP/View/Form.hs +++ b/IHP/View/Form.hs @@ -193,6 +193,7 @@ createFormContext record = FormContext { model = record , formAction = "" + , formMethod = "POST" , cssFramework = theCSSFramework , formId = "" , formClass = if isNew record then "new-form" else "edit-form" @@ -203,14 +204,20 @@ createFormContext record = -- | Used by 'formFor' to render the form buildForm :: forall model. (?context :: ControllerContext) => FormContext model -> ((?context :: ControllerContext, ?formContext :: FormContext model) => Html5.Html) -> Html5.Html -buildForm formContext inner = - let - theModel = model formContext - action = formAction formContext - formInner = let ?formContext = formContext in inner - customFormAttributes = get #customFormAttributes formContext - in - [hsx|{formInner}
|] +buildForm formContext inner = [hsx| +
+ {formInner} +
+ |] + where + formInner = let ?formContext = formContext in inner {-# INLINE buildForm #-} -- | Renders a submit button diff --git a/IHP/View/Types.hs b/IHP/View/Types.hs index 6bfd4a303..cc785fca1 100644 --- a/IHP/View/Types.hs +++ b/IHP/View/Types.hs @@ -72,6 +72,7 @@ data SubmitButton = SubmitButton data FormContext model = FormContext { model :: model -- ^ The record this form is based on , formAction :: !Text -- ^ Url where the form is submitted to + , formMethod :: !Text -- ^ Usually "POST", sometimes set to "GET" , cssFramework :: !CSSFramework , formClass :: !Text -- ^ In the generated HTML, the @class@ attribute will be set to this value , formId :: !Text -- ^ In the generated HTML, the @id@ attribute will be set to this value @@ -80,6 +81,7 @@ data FormContext model = FormContext } instance SetField "model" (FormContext record) record where setField value record = record { model = value } instance SetField "formAction" (FormContext record) Text where setField value record = record { formAction = value } +instance SetField "formMethod" (FormContext record) Text where setField value record = record { formMethod = value } instance SetField "cssFramework" (FormContext record) CSSFramework where setField value record = record { cssFramework = value } instance SetField "formClass" (FormContext record) Text where setField value record = record { formClass = value } instance SetField "formId" (FormContext record) Text where setField value record = record { formId = value } diff --git a/Test/Main.hs b/Test/Main.hs index 36106fe7a..61f00a1d4 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -32,6 +32,7 @@ import qualified Test.HSX.ParserSpec import qualified Test.NameSupportSpec import qualified Test.HaskellSupportSpec import qualified Test.View.CSSFrameworkSpec +import qualified Test.View.FormSpec import qualified Test.Controller.ContextSpec import qualified Test.Controller.ParamSpec import qualified Test.Controller.CookieSpec @@ -71,6 +72,7 @@ main = hspec do Test.HaskellSupportSpec.tests Test.HSX.ParserSpec.tests Test.View.CSSFrameworkSpec.tests + Test.View.FormSpec.tests Test.Controller.ContextSpec.tests Test.Controller.ParamSpec.tests Test.SchemaMigrationSpec.tests diff --git a/Test/View/FormSpec.hs b/Test/View/FormSpec.hs new file mode 100644 index 000000000..7b62046c8 --- /dev/null +++ b/Test/View/FormSpec.hs @@ -0,0 +1,96 @@ +{-| +Module: Test.View.FormSpec +Copyright: (c) digitally induced GmbH, 2022 +-} +module Test.View.FormSpec where + +import Test.Hspec +import IHP.FrameworkConfig as FrameworkConfig +import IHP.Controller.RequestContext +import qualified Text.Blaze.Renderer.Text as Blaze +import IHP.ModelSupport +import qualified Network.Wai as Wai +import IHP.ViewPrelude +import Data.Default +import qualified IHP.QueryBuilder as QueryBuilder + + +tests = do + describe "IHP.Form" do + describe "formFor" do + let project = newRecord @Project + + it "should render a form" do + context <- createControllerContext + let ?context = context + + let form = formFor project [hsx| + {textField #title} + {submitButton} + |] + form `shouldRenderTo` "
" + + it "should render a form with a GET method" do + context <- createControllerContext + let ?context = context + + let options formContext = formContext |> set #formMethod "GET" + + let form = formForWithOptions project options [hsx| + {textField #title} + {submitButton} + |] + form `shouldRenderTo` "
" + +shouldRenderTo renderFunction expectedHtml = Blaze.renderMarkup renderFunction `shouldBe` expectedHtml + +createControllerContext :: IO ControllerContext +createControllerContext = do + frameworkConfig <- FrameworkConfig.buildFrameworkConfig (pure ()) + let requestBody = FormBody { params = [], files = [] } + let request = Wai.defaultRequest + let requestContext = RequestContext { request, respond = undefined, requestBody, vault = undefined, frameworkConfig = frameworkConfig } + pure FrozenControllerContext { requestContext, customFields = mempty } + +data Project' = Project {id :: (Id' "projects"), title :: Text, meta :: MetaBag} deriving (Eq, Show) +instance InputValue Project where inputValue = IHP.ModelSupport.recordToInputValue +type Project = Project' + +type instance GetTableName (Project' ) = "projects" +type instance GetModelByTableName "projects" = Project +type instance GetModelName (Project' ) = "Project" + +type instance PrimaryKey "projects" = UUID + +instance Record Project where + {-# INLINE newRecord #-} + newRecord = Project def def def +instance Default (Id' "projects") where def = Id def + +instance SetField "id" (Project' ) (Id' "projects") where + {-# INLINE setField #-} + setField newValue (Project id title meta) = + Project newValue title (meta { touchedFields = "id" : touchedFields meta }) +instance SetField "title" (Project' ) Text where + {-# INLINE setField #-} + setField newValue (Project id title meta) = + Project id newValue (meta { touchedFields = "title" : touchedFields meta }) +instance SetField "meta" (Project' ) MetaBag where + {-# INLINE setField #-} + setField newValue (Project id title meta) = + Project id title newValue +instance UpdateField "id" (Project' ) (Project' ) (Id' "projects") (Id' "projects") where + {-# INLINE updateField #-} + updateField newValue (Project id title meta) = Project newValue title (meta { touchedFields = "id" : touchedFields meta }) +instance UpdateField "title" (Project' ) (Project' ) Text Text where + {-# INLINE updateField #-} + updateField newValue (Project id title meta) = Project id newValue (meta { touchedFields = "title" : touchedFields meta }) +instance UpdateField "meta" (Project' ) (Project' ) MetaBag MetaBag where + {-# INLINE updateField #-} + updateField newValue (Project id title meta) = Project id title newValue + + + + + +