From 11655cdbabc320efc98de376f3a560a9f90c1b70 Mon Sep 17 00:00:00 2001 From: Dillon Kearns Date: Mon, 23 May 2022 14:13:21 -0700 Subject: [PATCH] Add Pages.Msg.Msg variant for running a fetcher. --- src/Pages/Internal/Platform.elm | 153 ++++++++++++++++++++++---------- src/Pages/Msg.elm | 15 +++- 2 files changed, 119 insertions(+), 49 deletions(-) diff --git a/src/Pages/Internal/Platform.elm b/src/Pages/Internal/Platform.elm index 4b004941..0d2501b3 100644 --- a/src/Pages/Internal/Platform.elm +++ b/src/Pages/Internal/Platform.elm @@ -299,7 +299,7 @@ type Msg userMsg pageData actionData sharedData errorPage | UrlChanged Url | UserMsg (Pages.Msg.Msg userMsg) | UpdateCacheAndUrlNew Bool Url (Maybe userMsg) (Result Http.Error ( Url, ResponseSketch pageData actionData sharedData )) - | FetcherComplete Int (Result Http.Error userMsg) + | FetcherComplete Int (Result Http.Error (Maybe userMsg)) | FetcherStarted FormDecoder.FormData | PageScrollComplete | HotReloadCompleteNew Bytes @@ -336,6 +336,7 @@ type Effect userMsg pageData actionData sharedData userEffect errorPage | BrowserReplaceUrl String | FetchPageData Int (Maybe FormDecoder.FormData) Url (Result Http.Error ( Url, ResponseSketch pageData actionData sharedData ) -> Msg userMsg pageData actionData sharedData errorPage) | Submit FormDecoder.FormData + | SubmitFetcher FormDecoder.FormData | Batch (List (Effect userMsg pageData actionData sharedData userEffect errorPage)) | UserCmd userEffect | CancelRequest Int @@ -400,7 +401,13 @@ update config appMsg model = } , NoEffect ) - |> performUserMsg userMsg config + |> (case userMsg of + Just justUserMsg -> + performUserMsg justUserMsg config + + Nothing -> + identity + ) |> startNewGetLoad (currentUrlWithPath model.url.path model) (UpdateCacheAndUrlNew False model.url Nothing) Err _ -> @@ -435,6 +442,11 @@ update config appMsg model = , Submit fields ) + Pages.Msg.SubmitFetcher fields -> + ( model + , SubmitFetcher fields + ) + UpdateCacheAndUrlNew fromLinkClick urlWithoutRedirectResolution maybeUserMsg updateResult -> -- TODO remove all fetchers that are in the state `FetcherReloading` here -- I think that's the right logic? case @@ -688,6 +700,9 @@ perform config model effect = , fetchRouteData -1 (UpdateCacheAndUrlNew False model.url Nothing) config urlToSubmitTo (Just fields) ] + SubmitFetcher formData -> + startFetcher2 formData model + UserCmd cmd -> case model.key of Just key -> @@ -715,51 +730,7 @@ perform config model effect = fetchRouteData -1 (prepare fetchInfo.toMsg) config (fetchInfo.values.action |> Url.fromString |> Maybe.withDefault model.url) (Just fetchInfo.values) , runFetcher = \(Pages.Fetcher.Fetcher options) -> - let - encodedBody : String - encodedBody = - FormDecoder.encodeFormData - { fields = options.fields - - -- TODO remove hardcoding - , action = "" - - -- TODO remove hardcoding - , method = FormDecoder.Post - } - - formData = - { -- TODO remove hardcoding - method = FormDecoder.Get - - -- TODO pass FormData directly - , action = options.url |> Maybe.withDefault model.url.path - , fields = options.fields - } - in - -- TODO make sure that `actionData` isn't updated in Model for fetchers - Cmd.batch - [ Task.succeed (FetcherStarted formData) |> Task.perform identity - , Http.request - { expect = - Http.expectBytesResponse (FetcherComplete model.nextTransitionKey) - (\bytes -> - case bytes of - Http.GoodStatus_ metadata bytesBody -> - options.decoder (Ok bytesBody) - |> Ok - - _ -> - Debug.todo "" - ) - , tracker = Nothing - , body = Http.stringBody "application/x-www-form-urlencoded" encodedBody - , headers = options.headers |> List.map (\( name, value ) -> Http.header name value) - , url = options.url |> Maybe.withDefault (Path.join [ model.url.path, "content.dat" ] |> Path.toAbsolute) - , method = "POST" - , timeout = Nothing - } - ] + startFetcher options model , fromPageMsg = Pages.Msg.UserMsg >> UserMsg , key = key } @@ -771,6 +742,94 @@ perform config model effect = Http.cancel (String.fromInt transitionKey) +startFetcher : { fields : List ( String, String ), url : Maybe String, decoder : Result error Bytes -> value, headers : List ( String, String ) } -> Model userModel pageData actionData sharedData -> Cmd (Msg value pageData actionData sharedData errorPage) +startFetcher options model = + let + encodedBody : String + encodedBody = + FormDecoder.encodeFormData + { fields = options.fields + + -- TODO remove hardcoding + , action = "" + + -- TODO remove hardcoding + , method = FormDecoder.Post + } + + formData = + { -- TODO remove hardcoding + method = FormDecoder.Get + + -- TODO pass FormData directly + , action = options.url |> Maybe.withDefault model.url.path + , fields = options.fields + } + in + -- TODO make sure that `actionData` isn't updated in Model for fetchers + Cmd.batch + [ Task.succeed (FetcherStarted formData) |> Task.perform identity + , Http.request + { expect = + Http.expectBytesResponse (FetcherComplete model.nextTransitionKey) + (\bytes -> + case bytes of + Http.GoodStatus_ metadata bytesBody -> + options.decoder (Ok bytesBody) + |> Just + |> Ok + + _ -> + Debug.todo "" + ) + , tracker = Nothing + , body = Http.stringBody "application/x-www-form-urlencoded" encodedBody + , headers = options.headers |> List.map (\( name, value ) -> Http.header name value) + , url = options.url |> Maybe.withDefault (Path.join [ model.url.path, "content.dat" ] |> Path.toAbsolute) + , method = "POST" + , timeout = Nothing + } + ] + + +startFetcher2 : FormDecoder.FormData -> Model userModel pageData actionData sharedData -> Cmd (Msg userMsg pageData actionData sharedData errorPage) +startFetcher2 formData model = + let + encodedBody : String + encodedBody = + FormDecoder.encodeFormData formData + in + -- TODO make sure that `actionData` isn't updated in Model for fetchers + Cmd.batch + [ Task.succeed (FetcherStarted formData) |> Task.perform identity + , Http.request + { expect = + Http.expectBytesResponse (FetcherComplete model.nextTransitionKey) + (\bytes -> + case bytes of + Http.GoodStatus_ metadata bytesBody -> + -- TODO maybe have an optional way to pass the bytes through? + Ok Nothing + + _ -> + -- TODO where should errors go in application state? Should there be an onError where you can receive application-managed error events that are owned by + -- the Platform Model/Msg's? + Debug.todo "" + ) + , tracker = Nothing + + -- TODO use formData.method to do either query params or POST body + , body = Http.stringBody "application/x-www-form-urlencoded" encodedBody + , headers = [] + + -- TODO use formData.method to do either query params or POST body + , url = formData.action |> Url.fromString |> Maybe.map (\{ path } -> Path.join [ path, "content.dat" ] |> Path.toAbsolute) |> Maybe.withDefault "/" + , method = formData.method |> FormDecoder.methodToString + , timeout = Nothing + } + ] + + appendFormQueryParams : FormDecoder.FormData -> String appendFormQueryParams fields = (fields.action diff --git a/src/Pages/Msg.elm b/src/Pages/Msg.elm index c565c7c8..3f787162 100644 --- a/src/Pages/Msg.elm +++ b/src/Pages/Msg.elm @@ -1,13 +1,13 @@ module Pages.Msg exposing ( Msg(..) - , map, onSubmit + , map, onSubmit, fetcherOnSubmit ) {-| @docs Msg -@docs map, onSubmit +@docs map, onSubmit, fetcherOnSubmit -} @@ -20,6 +20,7 @@ import Html.Attributes type Msg userMsg = UserMsg userMsg | Submit FormDecoder.FormData + | SubmitFetcher FormDecoder.FormData {-| -} @@ -29,6 +30,13 @@ onSubmit = |> Html.Attributes.map Submit +{-| -} +fetcherOnSubmit : Attribute (Msg userMsg) +fetcherOnSubmit = + FormDecoder.formDataOnSubmit + |> Html.Attributes.map SubmitFetcher + + {-| -} map : (a -> b) -> Msg a -> Msg b map mapFn msg = @@ -38,3 +46,6 @@ map mapFn msg = Submit info -> Submit info + + SubmitFetcher info -> + SubmitFetcher info