Add part8

intro/part8/src/Page/Register.elm

@@ -0,0 +1,319 @@
+module Page.Register exposing (Model, Msg, init, subscriptions, toSession, update, view)
+
+import Api
+import Browser.Navigation as Nav
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.Events exposing (..)
+import Http
+import Json.Decode as Decode exposing (Decoder, decodeString, field, string)
+import Json.Decode.Pipeline exposing (optional)
+import Json.Encode as Encode
+import Route exposing (Route)
+import Session exposing (Session)
+import Viewer exposing (Viewer)
+import Viewer.Cred as Cred exposing (Cred)
+
+
+
+-- MODEL
+
+
+type alias Model =
+    { session : Session
+    , problems : List Problem
+    , form : Form
+    }
+
+
+type alias Form =
+    { email : String
+    , username : String
+    , password : String
+    }
+
+
+type Problem
+    = InvalidEntry ValidatedField String
+    | ServerError String
+
+
+init : Session -> ( Model, Cmd msg )
+init session =
+    ( { session = session
+      , problems = []
+      , form =
+            { email = ""
+            , username = ""
+            , password = ""
+            }
+      }
+    , Cmd.none
+    )
+
+
+
+-- VIEW
+
+
+view : Model -> { title : String, content : Html Msg }
+view model =
+    { title = "Register"
+    , content =
+        div [ class "cred-page" ]
+            [ div [ class "container page" ]
+                [ div [ class "row" ]
+                    [ div [ class "col-md-6 offset-md-3 col-xs-12" ]
+                        [ h1 [ class "text-xs-center" ] [ text "Sign up" ]
+                        , p [ class "text-xs-center" ]
+                            [ a [ Route.href Route.Login ]
+                                [ text "Have an account?" ]
+                            ]
+                        , ul [ class "error-messages" ]
+                            (List.map viewProblem model.problems)
+                        , viewForm model.form
+                        ]
+                    ]
+                ]
+            ]
+    }
+
+
+viewForm : Form -> Html Msg
+viewForm form =
+    Html.form [ onSubmit SubmittedForm ]
+        [ fieldset [ class "form-group" ]
+            [ input
+                [ class "form-control form-control-lg"
+                , placeholder "Username"
+                , onInput EnteredUsername
+                , value form.username
+                ]
+                []
+            ]
+        , fieldset [ class "form-group" ]
+            [ input
+                [ class "form-control form-control-lg"
+                , placeholder "Email"
+                , onInput EnteredEmail
+                , value form.email
+                ]
+                []
+            ]
+        , fieldset [ class "form-group" ]
+            [ input
+                [ class "form-control form-control-lg"
+                , type_ "password"
+                , placeholder "Password"
+                , onInput EnteredPassword
+                , value form.password
+                ]
+                []
+            ]
+        , button [ class "btn btn-lg btn-primary pull-xs-right" ]
+            [ text "Sign up" ]
+        ]
+
+
+viewProblem : Problem -> Html msg
+viewProblem problem =
+    let
+        errorMessage =
+            case problem of
+                InvalidEntry _ str ->
+                    str
+
+                ServerError str ->
+                    str
+    in
+    li [] [ text errorMessage ]
+
+
+
+-- UPDATE
+
+
+type Msg
+    = SubmittedForm
+    | EnteredEmail String
+    | EnteredUsername String
+    | EnteredPassword String
+    | CompletedRegister (Result Http.Error Viewer)
+    | GotSession Session
+
+
+update : Msg -> Model -> ( Model, Cmd Msg )
+update msg model =
+    case msg of
+        SubmittedForm ->
+            case validate model.form of
+                Ok validForm ->
+                    ( { model | problems = [] }
+                    , Http.send CompletedRegister (register validForm)
+                    )
+
+                Err problems ->
+                    ( { model | problems = problems }
+                    , Cmd.none
+                    )
+
+        EnteredUsername username ->
+            updateForm (\form -> { form | username = username }) model
+
+        EnteredEmail email ->
+            updateForm (\form -> { form | email = email }) model
+
+        EnteredPassword password ->
+            updateForm (\form -> { form | password = password }) model
+
+        CompletedRegister (Err error) ->
+            let
+                serverErrors =
+                    Api.decodeErrors error
+                        |> List.map ServerError
+            in
+            ( { model | problems = List.append model.problems serverErrors }
+            , Cmd.none
+            )
+
+        CompletedRegister (Ok viewer) ->
+            ( model
+            , Session.login viewer
+            )
+
+        GotSession session ->
+            ( { model | session = session }
+            , Route.replaceUrl (Session.navKey session) Route.Home
+            )
+
+
+{-| Helper function for `update`. Updates the form and returns Cmd.none and
+Ignored. Useful for recording form fields!
+-}
+updateForm : (Form -> Form) -> Model -> ( Model, Cmd Msg )
+updateForm transform model =
+    ( { model | form = transform model.form }, Cmd.none )
+
+
+
+-- SUBSCRIPTIONS
+
+
+subscriptions : Model -> Sub Msg
+subscriptions model =
+    Session.changes GotSession (Session.navKey model.session)
+
+
+
+-- EXPORT
+
+
+toSession : Model -> Session
+toSession model =
+    model.session
+
+
+
+-- FORM
+
+
+{-| Marks that we've trimmed the form's fields, so we don't accidentally send
+it to the server without having trimmed it!
+-}
+type TrimmedForm
+    = Trimmed Form
+
+
+{-| When adding a variant here, add it to `fieldsToValidate` too!
+-}
+type ValidatedField
+    = Username
+    | Email
+    | Password
+
+
+fieldsToValidate : List ValidatedField
+fieldsToValidate =
+    [ Username
+    , Email
+    , Password
+    ]
+
+
+{-| Trim the form and validate its fields. If there are problems, report them!
+-}
+validate : Form -> Result (List Problem) TrimmedForm
+validate form =
+    let
+        trimmedForm =
+            trimFields form
+    in
+    case List.concatMap (validateField trimmedForm) fieldsToValidate of
+        [] ->
+            Ok trimmedForm
+
+        problems ->
+            Err problems
+
+
+validateField : TrimmedForm -> ValidatedField -> List Problem
+validateField (Trimmed form) field =
+    List.map (InvalidEntry field) <|
+        case field of
+            Username ->
+                if String.isEmpty form.username then
+                    [ "username can't be blank." ]
+
+                else
+                    []
+
+            Email ->
+                if String.isEmpty form.email then
+                    [ "email can't be blank." ]
+
+                else
+                    []
+
+            Password ->
+                if String.isEmpty form.password then
+                    [ "password can't be blank." ]
+
+                else if String.length form.password < Viewer.minPasswordChars then
+                    [ "password must be at least " ++ String.fromInt Viewer.minPasswordChars ++ " characters long." ]
+
+                else
+                    []
+
+
+{-| Don't trim while the user is typing! That would be super annoying.
+Instead, trim only on submit.
+-}
+trimFields : Form -> TrimmedForm
+trimFields form =
+    Trimmed
+        { username = String.trim form.username
+        , email = String.trim form.email
+        , password = String.trim form.password
+        }
+
+
+
+-- HTTP
+
+
+register : TrimmedForm -> Http.Request Viewer
+register (Trimmed form) =
+    let
+        user =
+            Encode.object
+                [ ( "username", Encode.string form.username )
+                , ( "email", Encode.string form.email )
+                , ( "password", Encode.string form.password )
+                ]
+
+        body =
+            Encode.object [ ( "user", user ) ]
+                |> Http.jsonBody
+    in
+    Decode.field "user" Viewer.decoder
+        |> Http.post (Api.url [ "users" ]) body