Allow formFor with GET method

Fixes #1536

Guide/form.markdown

@@ -793,6 +793,27 @@ The generated HTML will look like this:
 <form data-post-id="bd20f13d-e04b-4ef2-be62-64707cbda980">
 ```
 
+### 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
+<form method="GET">
+```
+
+
 ### Disable Form Submission via JavaScript
 
 Your form will be submitted using AJAX and TurboLinks instead of browser-based form submission.

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|<form method="POST" action={action} id={get #formId formContext} class={get #formClass formContext} data-disable-javascript-submission={get #disableJavascriptSubmission formContext} {...customFormAttributes}>{formInner}</form>|]
+buildForm formContext inner = [hsx|
+        <form
+            method={formContext.formMethod}
+            action={formContext.formAction}
+            id={formContext.formId}
+            class={formContext.formClass}
+            data-disable-javascript-submission={formContext.disableJavascriptSubmission}
+            {...formContext.customFormAttributes}
+        >
+            {formInner}
+        </form>
+    |]
+        where
+            formInner = let ?formContext = formContext in inner
 {-# INLINE buildForm #-}
 
 -- | Renders a submit button

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 }

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

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` "<form method=\"POST\" action=\"/CreateProject\" id=\"\" class=\"new-form\" data-disable-javascript-submission=\"false\"><div class=\"form-group\" id=\"form-group-project_title\"><label class=\"\" for=\"project_title\">Title</label><input type=\"text\" name=\"title\" placeholder=\"\" id=\"project_title\" class=\"form-control\"> </div> <button class=\"btn btn-primary\" type=\"submit\">Create Project</button></form>"
+
+            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` "<form method=\"GET\" action=\"/CreateProject\" id=\"\" class=\"new-form\" data-disable-javascript-submission=\"false\"><div class=\"form-group\" id=\"form-group-project_title\"><label class=\"\" for=\"project_title\">Title</label><input type=\"text\" name=\"title\" placeholder=\"\" id=\"project_title\" class=\"form-control\"> </div> <button class=\"btn btn-primary\" type=\"submit\">Create Project</button></form>"
+
+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
+
+
+
+
+
+