Add function to submit form with elm/http request.

examples/pokedex/src/Page/Form.elm

@@ -278,7 +278,7 @@ view maybeUrl sharedModel static =
             []
             [ Html.text <| "Edit profile " ++ user.first ++ " " ++ user.last ]
         , form user
-            |> Form.toHtml Html.form (static.data.errors |> Maybe.withDefault Form.init)
+            |> Form.toHtml { pageReloadSubmit = True } Html.form (static.data.errors |> Maybe.withDefault Form.init)
             |> Html.map (\_ -> ())
         ]
     }

examples/pokedex/src/Page/TailwindForm.elm

@@ -9,8 +9,10 @@ import Form exposing (Form)
 import Head
 import Head.Seo as Seo
 import Html as CoreHtml
+import Html.Events
 import Html.Styled as Html exposing (Html)
 import Html.Styled.Attributes as Attr exposing (css)
+import Http
 import Icon
 import Page exposing (Page, PageWithState, StaticPayload)
 import PageServerResponse exposing (PageServerResponse)
@@ -31,6 +33,7 @@ type alias Model =
 
 type Msg
     = FormMsg Form.Msg
+    | GotFormResponse (Result Http.Error Form.Model)
 
 
 type alias RouteParams =
@@ -431,7 +434,20 @@ page =
 update _ _ _ _ msg model =
     case msg of
         FormMsg formMsg ->
-            ( { model | form = model.form |> Form.update (form defaultUser) formMsg }, Cmd.none )
+            case formMsg of
+                Form.SubmitForm ->
+                    ( model, Form.http "/tailwind-form" (form defaultUser) model.form |> Cmd.map GotFormResponse )
+
+                _ ->
+                    ( { model | form = model.form |> Form.update (form defaultUser) formMsg }, Cmd.none )
+
+        GotFormResponse result ->
+            case result of
+                Ok updatedFormModel ->
+                    ( { model | form = updatedFormModel }, Cmd.none )
+
+                Err _ ->
+                    ( model, Cmd.none )
 
 
 init _ _ static =
@@ -447,7 +463,8 @@ type alias Data =
 data : RouteParams -> Request (DataSource (PageServerResponse Data))
 data routeParams =
     Request.oneOf
-        [ Form.toRequest2 (form defaultUser)
+        [ Form.apiHandler (form defaultUser)
+        , Form.toRequest2 (form defaultUser)
             |> Request.map
                 (\userOrErrors ->
                     userOrErrors
@@ -597,7 +614,7 @@ view maybeUrl sharedModel model static =
                     ]
                 ]
                 [ form user
-                    |> Form.toHtml
+                    |> Form.toHtml { pageReloadSubmit = True }
                         (\attrs children -> Html.form (List.map Attr.fromUnstyled attrs) children)
                         model.form
                     |> Html.map FormMsg

src/Form.elm

@@ -7,10 +7,53 @@ import Dict.Extra
 import Html exposing (Html)
 import Html.Attributes as Attr
 import Html.Events
+import Http
+import Json.Decode as Decode
 import Json.Encode as Encode
 import List.Extra
 import List.NonEmpty
+import PageServerResponse exposing (PageServerResponse)
 import Server.Request as Request exposing (Request)
+import Server.Response
+import Url
+
+
+http : String -> Form value view -> Model -> Cmd (Result Http.Error Model)
+http url_ (Form fields decoder serverValidations modelToValue) model =
+    Http.request
+        { method = "POST"
+        , headers =
+            [ Http.header "accept" "application/json"
+            ]
+        , body =
+            model
+                |> Dict.toList
+                |> List.map
+                    (\( name, { raw } ) ->
+                        Url.percentEncode name
+                            ++ "="
+                            ++ Url.percentEncode
+                                (raw |> Maybe.withDefault "")
+                    )
+                |> String.join "&"
+                |> Http.stringBody "application/x-www-form-urlencoded"
+        , expect =
+            Http.expectJson identity
+                (Decode.dict
+                    (Decode.map2
+                        (\raw errors ->
+                            { raw = raw
+                            , errors = errors
+                            }
+                        )
+                        (Decode.field "raw" (Decode.nullable Decode.string))
+                        (Decode.field "errors" (Decode.list Decode.string))
+                    )
+                )
+        , timeout = Nothing
+        , tracker = Nothing
+        , url = url_
+        }
 
 
 type Form value view
@@ -100,6 +143,7 @@ type Msg
     = OnFieldInput { name : String, value : String }
     | OnFieldFocus { name : String }
     | OnBlur
+    | SubmitForm
 
 
 type alias Model =
@@ -162,6 +206,9 @@ update form msg model =
         OnBlur ->
             model
 
+        SubmitForm ->
+            model
+
 
 init : Model
 init =
@@ -903,11 +950,12 @@ simplify3 field =
 
 
 toHtml :
-    (List (Html.Attribute msg) -> List view -> view)
+    { pageReloadSubmit : Bool }
+    -> (List (Html.Attribute Msg) -> List view -> view)
     -> Dict String { raw : Maybe String, errors : List String }
     -> Form value view
     -> view
-toHtml toForm serverValidationErrors (Form fields decoder serverValidations modelToValue) =
+toHtml { pageReloadSubmit } toForm serverValidationErrors (Form fields decoder serverValidations modelToValue) =
     let
         hasErrors_ : Bool
         hasErrors_ =
@@ -916,8 +964,15 @@ toHtml toForm serverValidationErrors (Form fields decoder serverValidations mode
                 serverValidationErrors
     in
     toForm
-        [ Attr.method "POST"
-        ]
+        ([ [ Attr.method "POST" ]
+         , if pageReloadSubmit then
+            [ Html.Events.onSubmit SubmitForm ]
+
+           else
+            []
+         ]
+            |> List.concat
+        )
         (fields
             |> List.reverse
             |> List.concatMap
@@ -946,6 +1001,57 @@ toRequest (Form fields decoder serverValidations modelToValue) =
         )
 
 
+apiHandler :
+    Form value view
+    -> Request (DataSource (PageServerResponse response))
+apiHandler (Form fields decoder serverValidations modelToValue) =
+    let
+        encodeErrors errors =
+            errors
+                |> List.map
+                    (\( name, entry ) ->
+                        ( name
+                        , Encode.object
+                            [ ( "errors"
+                              , Encode.list Encode.string entry.errors
+                              )
+                            , ( "raw"
+                              , entry.raw |> Maybe.map Encode.string |> Maybe.withDefault Encode.null
+                              )
+                            ]
+                        )
+                    )
+                |> Encode.object
+    in
+    Request.map2
+        (\decoded errors ->
+            errors
+                |> DataSource.map
+                    (\validationErrors ->
+                        if hasErrors validationErrors then
+                            Server.Response.json
+                                (validationErrors |> encodeErrors)
+                                |> PageServerResponse.ServerResponse
+
+                        else
+                            Server.Response.json
+                                (validationErrors |> encodeErrors)
+                                |> PageServerResponse.ServerResponse
+                    )
+        )
+        (Request.expectFormPost
+            (\_ ->
+                decoder
+            )
+        )
+        (Request.expectFormPost
+            (\_ ->
+                serverValidations
+            )
+        )
+        |> Request.acceptContentTypes (List.NonEmpty.singleton "application/json")
+
+
 toRequest2 :
     Form value view
     ->
@@ -979,7 +1085,11 @@ toRequest2 (Form fields decoder serverValidations modelToValue) =
         )
         (Request.expectFormPost
             (\_ ->
-                serverValidations
+                Request.oneOf
+                    [ serverValidations
+                        |> Request.acceptContentTypes (List.NonEmpty.singleton "application/json")
+                    , serverValidations
+                    ]
             )
         )
 

src/Server/Request.elm

@@ -2,7 +2,8 @@ module Server.Request exposing
     ( Request(..)
     , Method(..), methodToString
     , succeed
-    , requestTime, optionalHeader, expectContentType, expectJsonBody, acceptMethod, jsonBodyResult
+    , requestTime, optionalHeader, expectContentType, expectJsonBody, jsonBodyResult
+    , acceptMethod, acceptContentTypes
     , map, map2, oneOf, andMap
     , expectQueryParam
     , cookie, expectCookie
@@ -21,7 +22,9 @@ module Server.Request exposing
 
 @docs succeed
 
-@docs requestTime, optionalHeader, expectContentType, expectJsonBody, acceptMethod, jsonBodyResult
+@docs requestTime, optionalHeader, expectContentType, expectJsonBody, jsonBodyResult
+
+@docs acceptMethod, acceptContentTypes
 
 
 ## Transforming
@@ -309,6 +312,27 @@ noErrors decoder =
         |> OptimizedDecoder.map (\value -> ( Ok value, [] ))
 
 
+{-| -}
+acceptContentTypes : ( String, List String ) -> Request value -> Request value
+acceptContentTypes ( accepted1, accepted ) (Request decoder) =
+    -- TODO this should parse content-types so it doesn't need to be an exact match (support `; q=...`, etc.)
+    OptimizedDecoder.optionalField ("Accept" |> String.toLower) OptimizedDecoder.string
+        |> OptimizedDecoder.field "headers"
+        |> OptimizedDecoder.andThen
+            (\acceptHeader ->
+                if List.NonEmpty.fromCons accepted1 accepted |> List.NonEmpty.member (acceptHeader |> Maybe.withDefault "") then
+                    decoder
+
+                else
+                    decoder
+                        |> appendError
+                            (ValidationError
+                                ("Expected Accept header " ++ String.join ", " (accepted1 :: accepted) ++ " but was " ++ (acceptHeader |> Maybe.withDefault ""))
+                            )
+            )
+        |> Request
+
+
 {-| -}
 acceptMethod : ( Method, List Method ) -> Request value -> Request value
 acceptMethod ( accepted1, accepted ) (Request decoder) =