diff --git a/.gitignore b/.gitignore index 9f3d315..a91429c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.tmp extension.tar.br # Logs diff --git a/ThirdPartyNotices.txt b/ThirdPartyNotices.txt new file mode 100644 index 0000000..592a4b8 --- /dev/null +++ b/ThirdPartyNotices.txt @@ -0,0 +1,28 @@ +This project incorporates components from the projects listed below, that may have licenses +differing from this project: + + +1) License Notice for test/cases/elm-spa* (from https://github.com/rtfeldman/elm-spa-example) +--------------------------------------- + +MIT License + +Copyright (c) 2017-2018 Richard Feldman and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/package.json b/package.json index 0fe5083..baa2b28 100644 --- a/package.json +++ b/package.json @@ -21,5 +21,42 @@ "prettier": { "semi": false, "singleQuote": true + }, + "test-tokenize": { + "skip": [ + "elm-spa-api-endpoint", + "elm-spa-api", + "elm-spa-article-body", + "elm-spa-article-comment", + "elm-spa-article-feed", + "elm-spa-article-slug", + "elm-spa-article-tag", + "elm-spa-article", + "elm-spa-asset", + "elm-spa-author", + "elm-spa-avatar", + "elm-spa-commentid", + "elm-spa-email", + "elm-spa-loading", + "elm-spa-log", + "elm-spa-main", + "elm-spa-page-article-editor", + "elm-spa-page-article", + "elm-spa-page-blank", + "elm-spa-page-home", + "elm-spa-page-login", + "elm-spa-page-notfound", + "elm-spa-page-profile", + "elm-spa-page-register", + "elm-spa-page-settings", + "elm-spa-page", + "elm-spa-paginatedlist", + "elm-spa-profile", + "elm-spa-route", + "elm-spa-session", + "elm-spa-timestamp", + "elm-spa-username", + "elm-spa-viewer" + ] } } diff --git a/scripts/copy-elm-spa-tests.js b/scripts/copy-elm-spa-tests.js new file mode 100644 index 0000000..96005f6 --- /dev/null +++ b/scripts/copy-elm-spa-tests.js @@ -0,0 +1,62 @@ +import { execaCommand } from 'execa' +import path, { dirname } from 'node:path' +import { fileURLToPath } from 'node:url' +import { cp, readdir, readFile, rm, writeFile } from 'node:fs/promises' + +const __dirname = dirname(fileURLToPath(import.meta.url)) +const root = path.join(__dirname, '..') + +const REPO = 'https://github.com/rtfeldman/elm-spa-example' +const COMMIT = 'cb32acd73c3d346d0064e7923049867d8ce67193' + +const getTestName = (line) => { + return ( + 'elm-spa-' + + line + .toLowerCase() + .trim() + .replaceAll(' ', '-') + .replaceAll('/', '-') + .replace('.elm', '') + ) +} + +const getAllTests = async (folder) => { + const dirents = await readdir(folder, { recursive: true }) + const allTests = [] + for (const dirent of dirents) { + if (!dirent.endsWith('.elm')) { + continue + } + const filePath = `${folder}/${dirent}` + const testName = getTestName(dirent) + const fileContent = await readFile(filePath, 'utf8') + allTests.push({ + testName, + testContent: fileContent, + }) + } + return allTests +} + +const writeTestFiles = async (allTests) => { + for (const test of allTests) { + await writeFile(`${root}/test/cases/${test.testName}.elm`, test.testContent) + } +} + +const main = async () => { + process.chdir(root) + await rm(`${root}/.tmp`, { recursive: true, force: true }) + await execaCommand(`git clone ${REPO} .tmp/elm-spa`) + process.chdir(`${root}/.tmp/elm-spa`) + await execaCommand(`git checkout ${COMMIT}`) + process.chdir(root) + await cp(`${root}/.tmp/elm-spa/src`, `${root}/.tmp/elm-spa-src`, { + recursive: true, + }) + const allTests = await getAllTests(`${root}/.tmp/elm-spa-src`) + await writeTestFiles(allTests) +} + +main() diff --git a/test/cases/elm-spa-api-endpoint.elm b/test/cases/elm-spa-api-endpoint.elm new file mode 100644 index 0000000..7812fdb --- /dev/null +++ b/test/cases/elm-spa-api-endpoint.elm @@ -0,0 +1,127 @@ +module Api.Endpoint exposing (Endpoint, article, articles, comment, comments, favorite, feed, follow, login, profiles, request, tags, user, users) + +import Article.Slug as Slug exposing (Slug) +import CommentId exposing (CommentId) +import Http +import Url.Builder exposing (QueryParameter) +import Username exposing (Username) + + +{-| Http.request, except it takes an Endpoint instead of a Url. +-} +request : + { body : Http.Body + , expect : Http.Expect a + , headers : List Http.Header + , method : String + , timeout : Maybe Float + , url : Endpoint + , withCredentials : Bool + } + -> Http.Request a +request config = + Http.request + { body = config.body + , expect = config.expect + , headers = config.headers + , method = config.method + , timeout = config.timeout + , url = unwrap config.url + , withCredentials = config.withCredentials + } + + + +-- TYPES + + +{-| Get a URL to the Conduit API. + +This is not publicly exposed, because we want to make sure the only way to get one of these URLs is from this module. + +-} +type Endpoint + = Endpoint String + + +unwrap : Endpoint -> String +unwrap (Endpoint str) = + str + + +url : List String -> List QueryParameter -> Endpoint +url paths queryParams = + -- NOTE: Url.Builder takes care of percent-encoding special URL characters. + -- See https://package.elm-lang.org/packages/elm/url/latest/Url#percentEncode + Url.Builder.crossOrigin "https://conduit.productionready.io" + ("api" :: paths) + queryParams + |> Endpoint + + + +-- ENDPOINTS + + +login : Endpoint +login = + url [ "users", "login" ] [] + + +user : Endpoint +user = + url [ "user" ] [] + + +users : Endpoint +users = + url [ "users" ] [] + + +follow : Username -> Endpoint +follow uname = + url [ "profiles", Username.toString uname, "follow" ] [] + + + +-- ARTICLE ENDPOINTS + + +article : Slug -> Endpoint +article slug = + url [ "articles", Slug.toString slug ] [] + + +comments : Slug -> Endpoint +comments slug = + url [ "articles", Slug.toString slug, "comments" ] [] + + +comment : Slug -> CommentId -> Endpoint +comment slug commentId = + url [ "articles", Slug.toString slug, "comments", CommentId.toString commentId ] [] + + +favorite : Slug -> Endpoint +favorite slug = + url [ "articles", Slug.toString slug, "favorite" ] [] + + +articles : List QueryParameter -> Endpoint +articles params = + url [ "articles" ] params + + +profiles : Username -> Endpoint +profiles uname = + url [ "profiles", Username.toString uname ] [] + + +feed : List QueryParameter -> Endpoint +feed params = + url [ "articles", "feed" ] params + + +tags : Endpoint +tags = + url [ "tags" ] [] diff --git a/test/cases/elm-spa-api.elm b/test/cases/elm-spa-api.elm new file mode 100644 index 0000000..adce6e8 --- /dev/null +++ b/test/cases/elm-spa-api.elm @@ -0,0 +1,300 @@ +port module Api exposing (Cred, addServerError, application, decodeErrors, delete, get, login, logout, post, put, register, settings, storeCredWith, username, viewerChanges) + +{-| This module is responsible for communicating to the Conduit API. + +It exposes an opaque Endpoint type which is guaranteed to point to the correct URL. + +-} + +import Api.Endpoint as Endpoint exposing (Endpoint) +import Avatar exposing (Avatar) +import Browser +import Browser.Navigation as Nav +import Http exposing (Body, Expect) +import Json.Decode as Decode exposing (Decoder, Value, decodeString, field, string) +import Json.Decode.Pipeline as Pipeline exposing (optional, required) +import Json.Encode as Encode +import Url exposing (Url) +import Username exposing (Username) + + + +-- CRED + + +{-| The authentication credentials for the Viewer (that is, the currently logged-in user.) + +This includes: + + - The cred's Username + - The cred's authentication token + +By design, there is no way to access the token directly as a String. +It can be encoded for persistence, and it can be added to a header +to a HttpBuilder for a request, but that's it. + +This token should never be rendered to the end user, and with this API, it +can't be! + +-} +type Cred + = Cred Username String + + +username : Cred -> Username +username (Cred val _) = + val + + +credHeader : Cred -> Http.Header +credHeader (Cred _ str) = + Http.header "authorization" ("Token " ++ str) + + +{-| It's important that this is never exposed! + +We expose `login` and `application` instead, so we can be certain that if anyone +ever has access to a `Cred` value, it came from either the login API endpoint +or was passed in via flags. + +-} +credDecoder : Decoder Cred +credDecoder = + Decode.succeed Cred + |> required "username" Username.decoder + |> required "token" Decode.string + + + +-- PERSISTENCE + + +decode : Decoder (Cred -> viewer) -> Value -> Result Decode.Error viewer +decode decoder value = + -- It's stored in localStorage as a JSON String; + -- first decode the Value as a String, then + -- decode that String as JSON. + Decode.decodeValue Decode.string value + |> Result.andThen (\str -> Decode.decodeString (Decode.field "user" (decoderFromCred decoder)) str) + + +port onStoreChange : (Value -> msg) -> Sub msg + + +viewerChanges : (Maybe viewer -> msg) -> Decoder (Cred -> viewer) -> Sub msg +viewerChanges toMsg decoder = + onStoreChange (\value -> toMsg (decodeFromChange decoder value)) + + +decodeFromChange : Decoder (Cred -> viewer) -> Value -> Maybe viewer +decodeFromChange viewerDecoder val = + -- It's stored in localStorage as a JSON String; + -- first decode the Value as a String, then + -- decode that String as JSON. + Decode.decodeValue (storageDecoder viewerDecoder) val + |> Result.toMaybe + + +storeCredWith : Cred -> Avatar -> Cmd msg +storeCredWith (Cred uname token) avatar = + let + json = + Encode.object + [ ( "user" + , Encode.object + [ ( "username", Username.encode uname ) + , ( "token", Encode.string token ) + , ( "image", Avatar.encode avatar ) + ] + ) + ] + in + storeCache (Just json) + + +logout : Cmd msg +logout = + storeCache Nothing + + +port storeCache : Maybe Value -> Cmd msg + + + +-- SERIALIZATION +-- APPLICATION + + +application : + Decoder (Cred -> viewer) + -> + { init : Maybe viewer -> Url -> Nav.Key -> ( model, Cmd msg ) + , onUrlChange : Url -> msg + , onUrlRequest : Browser.UrlRequest -> msg + , subscriptions : model -> Sub msg + , update : msg -> model -> ( model, Cmd msg ) + , view : model -> Browser.Document msg + } + -> Program Value model msg +application viewerDecoder config = + let + init flags url navKey = + let + maybeViewer = + Decode.decodeValue Decode.string flags + |> Result.andThen (Decode.decodeString (storageDecoder viewerDecoder)) + |> Result.toMaybe + in + config.init maybeViewer url navKey + in + Browser.application + { init = init + , onUrlChange = config.onUrlChange + , onUrlRequest = config.onUrlRequest + , subscriptions = config.subscriptions + , update = config.update + , view = config.view + } + + +storageDecoder : Decoder (Cred -> viewer) -> Decoder viewer +storageDecoder viewerDecoder = + Decode.field "user" (decoderFromCred viewerDecoder) + + + +-- HTTP + + +get : Endpoint -> Maybe Cred -> Decoder a -> Http.Request a +get url maybeCred decoder = + Endpoint.request + { method = "GET" + , url = url + , expect = Http.expectJson decoder + , headers = + case maybeCred of + Just cred -> + [ credHeader cred ] + + Nothing -> + [] + , body = Http.emptyBody + , timeout = Nothing + , withCredentials = False + } + + +put : Endpoint -> Cred -> Body -> Decoder a -> Http.Request a +put url cred body decoder = + Endpoint.request + { method = "PUT" + , url = url + , expect = Http.expectJson decoder + , headers = [ credHeader cred ] + , body = body + , timeout = Nothing + , withCredentials = False + } + + +post : Endpoint -> Maybe Cred -> Body -> Decoder a -> Http.Request a +post url maybeCred body decoder = + Endpoint.request + { method = "POST" + , url = url + , expect = Http.expectJson decoder + , headers = + case maybeCred of + Just cred -> + [ credHeader cred ] + + Nothing -> + [] + , body = body + , timeout = Nothing + , withCredentials = False + } + + +delete : Endpoint -> Cred -> Body -> Decoder a -> Http.Request a +delete url cred body decoder = + Endpoint.request + { method = "DELETE" + , url = url + , expect = Http.expectJson decoder + , headers = [ credHeader cred ] + , body = body + , timeout = Nothing + , withCredentials = False + } + + +login : Http.Body -> Decoder (Cred -> a) -> Http.Request a +login body decoder = + post Endpoint.login Nothing body (Decode.field "user" (decoderFromCred decoder)) + + +register : Http.Body -> Decoder (Cred -> a) -> Http.Request a +register body decoder = + post Endpoint.users Nothing body (Decode.field "user" (decoderFromCred decoder)) + + +settings : Cred -> Http.Body -> Decoder (Cred -> a) -> Http.Request a +settings cred body decoder = + put Endpoint.user cred body (Decode.field "user" (decoderFromCred decoder)) + + +decoderFromCred : Decoder (Cred -> a) -> Decoder a +decoderFromCred decoder = + Decode.map2 (\fromCred cred -> fromCred cred) + decoder + credDecoder + + + +-- ERRORS + + +addServerError : List String -> List String +addServerError list = + "Server error" :: list + + +{-| Many API endpoints include an "errors" field in their BadStatus responses. +-} +decodeErrors : Http.Error -> List String +decodeErrors error = + case error of + Http.BadStatus response -> + response.body + |> decodeString (field "errors" errorsDecoder) + |> Result.withDefault [ "Server error" ] + + err -> + [ "Server error" ] + + +errorsDecoder : Decoder (List String) +errorsDecoder = + Decode.keyValuePairs (Decode.list Decode.string) + |> Decode.map (List.concatMap fromPair) + + +fromPair : ( String, List String ) -> List String +fromPair ( field, errors ) = + List.map (\error -> field ++ " " ++ error) errors + + + +-- LOCALSTORAGE KEYS + + +cacheStorageKey : String +cacheStorageKey = + "cache" + + +credStorageKey : String +credStorageKey = + "cred" diff --git a/test/cases/elm-spa-article-body.elm b/test/cases/elm-spa-article-body.elm new file mode 100644 index 0000000..b1c55f1 --- /dev/null +++ b/test/cases/elm-spa-article-body.elm @@ -0,0 +1,38 @@ +module Article.Body exposing (Body, MarkdownString, decoder, toHtml, toMarkdownString) + +import Html exposing (Attribute, Html) +import Json.Decode as Decode exposing (Decoder) +import Markdown + + + +-- TYPES + + +type Body + = Body MarkdownString + + +{-| Internal use only. I want to remind myself that the string inside Body contains markdown. +-} +type alias MarkdownString = + String + + + +-- CONVERSIONS + + +toHtml : Body -> List (Attribute msg) -> Html msg +toHtml (Body markdown) attributes = + Markdown.toHtml attributes markdown + + +toMarkdownString : Body -> MarkdownString +toMarkdownString (Body markdown) = + markdown + + +decoder : Decoder Body +decoder = + Decode.map Body Decode.string diff --git a/test/cases/elm-spa-article-comment.elm b/test/cases/elm-spa-article-comment.elm new file mode 100644 index 0000000..301799d --- /dev/null +++ b/test/cases/elm-spa-article-comment.elm @@ -0,0 +1,108 @@ +module Article.Comment exposing (Comment, author, body, createdAt, delete, id, list, post) + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article exposing (Article) +import Article.Slug as Slug exposing (Slug) +import Author exposing (Author) +import CommentId exposing (CommentId) +import Http +import Iso8601 +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (custom, required) +import Json.Encode as Encode exposing (Value) +import Profile exposing (Profile) +import Time + + + +-- TYPES + + +type Comment + = Comment Internals + + +type alias Internals = + { id : CommentId + , body : String + , createdAt : Time.Posix + , author : Author + } + + + +-- INFO + + +id : Comment -> CommentId +id (Comment comment) = + comment.id + + +body : Comment -> String +body (Comment comment) = + comment.body + + +createdAt : Comment -> Time.Posix +createdAt (Comment comment) = + comment.createdAt + + +author : Comment -> Author +author (Comment comment) = + comment.author + + + +-- LIST + + +list : Maybe Cred -> Slug -> Http.Request (List Comment) +list maybeCred articleSlug = + Decode.field "comments" (Decode.list (decoder maybeCred)) + |> Api.get (Endpoint.comments articleSlug) maybeCred + + + +-- POST + + +post : Slug -> String -> Cred -> Http.Request Comment +post articleSlug commentBody cred = + let + bod = + encodeCommentBody commentBody + |> Http.jsonBody + in + Decode.field "comment" (decoder (Just cred)) + |> Api.post (Endpoint.comments articleSlug) (Just cred) bod + + +encodeCommentBody : String -> Value +encodeCommentBody str = + Encode.object [ ( "comment", Encode.object [ ( "body", Encode.string str ) ] ) ] + + + +-- DELETE + + +delete : Slug -> CommentId -> Cred -> Http.Request () +delete articleSlug commentId cred = + Api.delete (Endpoint.comment articleSlug commentId) cred Http.emptyBody (Decode.succeed ()) + + + +-- SERIALIZATION + + +decoder : Maybe Cred -> Decoder Comment +decoder maybeCred = + Decode.succeed Internals + |> required "id" CommentId.decoder + |> required "body" Decode.string + |> required "createdAt" Iso8601.decoder + |> required "author" (Author.decoder maybeCred) + |> Decode.map Comment diff --git a/test/cases/elm-spa-article-feed.elm b/test/cases/elm-spa-article-feed.elm new file mode 100644 index 0000000..8e4f4bd --- /dev/null +++ b/test/cases/elm-spa-article-feed.elm @@ -0,0 +1,279 @@ +module Article.Feed exposing (Model, Msg, decoder, init, update, viewArticles, viewPagination, viewTabs) + +import Api exposing (Cred) +import Article exposing (Article, Preview) +import Article.Slug as ArticleSlug exposing (Slug) +import Article.Tag as Tag exposing (Tag) +import Author +import Avatar exposing (Avatar) +import Html exposing (..) +import Html.Attributes exposing (attribute, class, classList, href, id, placeholder, src) +import Html.Events exposing (onClick) +import Http +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (required) +import Page +import PaginatedList exposing (PaginatedList) +import Profile +import Route exposing (Route) +import Session exposing (Session) +import Task exposing (Task) +import Time +import Timestamp +import Url exposing (Url) +import Username exposing (Username) + + +{-| NOTE: This module has its own Model, view, and update. This is not normal! +If you find yourself doing this often, please watch + +This is the reusable Article Feed that appears on both the Home page as well as +on the Profile page. There's a lot of logic here, so it's more convenient to use +the heavyweight approach of giving this its own Model, view, and update. + +This means callers must use Html.map and Cmd.map to use this thing, but in +this case that's totally worth it because of the amount of logic wrapped up +in this thing. + +For every other reusable view in this application, this API would be totally +overkill, so we use simpler APIs instead. + +-} + + + +-- MODEL + + +type Model + = Model Internals + + +{-| This should not be exposed! We want to benefit from the guarantee that only +this module can create or alter this model. This way if it ever ends up in +a surprising state, we know exactly where to look: this module. +-} +type alias Internals = + { session : Session + , errors : List String + , articles : PaginatedList (Article Preview) + , isLoading : Bool + } + + +init : Session -> PaginatedList (Article Preview) -> Model +init session articles = + Model + { session = session + , errors = [] + , articles = articles + , isLoading = False + } + + + +-- VIEW + + +viewArticles : Time.Zone -> Model -> List (Html Msg) +viewArticles timeZone (Model { articles, session, errors }) = + let + maybeCred = + Session.cred session + + articlesHtml = + PaginatedList.values articles + |> List.map (viewPreview maybeCred timeZone) + in + Page.viewErrors ClickedDismissErrors errors :: articlesHtml + + +viewPreview : Maybe Cred -> Time.Zone -> Article Preview -> Html Msg +viewPreview maybeCred timeZone article = + let + slug = + Article.slug article + + { title, description, createdAt } = + Article.metadata article + + author = + Article.author article + + profile = + Author.profile author + + username = + Author.username author + + faveButton = + case maybeCred of + Just cred -> + let + { favoritesCount, favorited } = + Article.metadata article + + viewButton = + if favorited then + Article.unfavoriteButton cred (ClickedUnfavorite cred slug) + + else + Article.favoriteButton cred (ClickedFavorite cred slug) + in + viewButton [ class "pull-xs-right" ] + [ text (" " ++ String.fromInt favoritesCount) ] + + Nothing -> + text "" + in + div [ class "article-preview" ] + [ div [ class "article-meta" ] + [ a [ Route.href (Route.Profile username) ] + [ img [ Avatar.src (Profile.avatar profile) ] [] ] + , div [ class "info" ] + [ Author.view username + , Timestamp.view timeZone createdAt + ] + , faveButton + ] + , a [ class "preview-link", Route.href (Route.Article (Article.slug article)) ] + [ h1 [] [ text title ] + , p [] [ text description ] + , span [] [ text "Read more..." ] + , ul [ class "tag-list" ] + (List.map viewTag (Article.metadata article).tags) + ] + ] + + +viewTabs : + List ( String, msg ) + -> ( String, msg ) + -> List ( String, msg ) + -> Html msg +viewTabs before selected after = + ul [ class "nav nav-pills outline-active" ] <| + List.concat + [ List.map (viewTab []) before + , [ viewTab [ class "active" ] selected ] + , List.map (viewTab []) after + ] + + +viewTab : List (Attribute msg) -> ( String, msg ) -> Html msg +viewTab attrs ( name, msg ) = + li [ class "nav-item" ] + [ -- Note: The RealWorld CSS requires an href to work properly. + a (class "nav-link" :: onClick msg :: href "" :: attrs) + [ text name ] + ] + + +viewPagination : (Int -> msg) -> Int -> Model -> Html msg +viewPagination toMsg page (Model feed) = + let + viewPageLink currentPage = + pageLink toMsg currentPage (currentPage == page) + + totalPages = + PaginatedList.total feed.articles + in + if totalPages > 1 then + List.range 1 totalPages + |> List.map viewPageLink + |> ul [ class "pagination" ] + + else + Html.text "" + + +pageLink : (Int -> msg) -> Int -> Bool -> Html msg +pageLink toMsg targetPage isActive = + li [ classList [ ( "page-item", True ), ( "active", isActive ) ] ] + [ a + [ class "page-link" + , onClick (toMsg targetPage) + + -- The RealWorld CSS requires an href to work properly. + , href "" + ] + [ text (String.fromInt targetPage) ] + ] + + +viewTag : String -> Html msg +viewTag tagName = + li [ class "tag-default tag-pill tag-outline" ] [ text tagName ] + + + +-- UPDATE + + +type Msg + = ClickedDismissErrors + | ClickedFavorite Cred Slug + | ClickedUnfavorite Cred Slug + | CompletedFavorite (Result Http.Error (Article Preview)) + + +update : Maybe Cred -> Msg -> Model -> ( Model, Cmd Msg ) +update maybeCred msg (Model model) = + case msg of + ClickedDismissErrors -> + ( Model { model | errors = [] }, Cmd.none ) + + ClickedFavorite cred slug -> + fave Article.favorite cred slug model + + ClickedUnfavorite cred slug -> + fave Article.unfavorite cred slug model + + CompletedFavorite (Ok article) -> + ( Model { model | articles = PaginatedList.map (replaceArticle article) model.articles } + , Cmd.none + ) + + CompletedFavorite (Err error) -> + ( Model { model | errors = Api.addServerError model.errors } + , Cmd.none + ) + + +replaceArticle : Article a -> Article a -> Article a +replaceArticle newArticle oldArticle = + if Article.slug newArticle == Article.slug oldArticle then + newArticle + + else + oldArticle + + + +-- SERIALIZATION + + +decoder : Maybe Cred -> Int -> Decoder (PaginatedList (Article Preview)) +decoder maybeCred resultsPerPage = + Decode.succeed PaginatedList.fromList + |> required "articlesCount" (pageCountDecoder resultsPerPage) + |> required "articles" (Decode.list (Article.previewDecoder maybeCred)) + + +pageCountDecoder : Int -> Decoder Int +pageCountDecoder resultsPerPage = + Decode.int + |> Decode.map (\total -> ceiling (toFloat total / toFloat resultsPerPage)) + + + +-- INTERNAL + + +fave : (Slug -> Cred -> Http.Request (Article Preview)) -> Cred -> Slug -> Internals -> ( Model, Cmd Msg ) +fave toRequest cred slug model = + ( Model model + , toRequest slug cred + |> Http.toTask + |> Task.attempt CompletedFavorite + ) diff --git a/test/cases/elm-spa-article-slug.elm b/test/cases/elm-spa-article-slug.elm new file mode 100644 index 0000000..723f5f9 --- /dev/null +++ b/test/cases/elm-spa-article-slug.elm @@ -0,0 +1,35 @@ +module Article.Slug exposing (Slug, decoder, toString, urlParser) + +import Json.Decode as Decode exposing (Decoder) +import Url.Parser exposing (Parser) + + + +-- TYPES + + +type Slug + = Slug String + + + +-- CREATE + + +urlParser : Parser (Slug -> a) a +urlParser = + Url.Parser.custom "SLUG" (\str -> Just (Slug str)) + + +decoder : Decoder Slug +decoder = + Decode.map Slug Decode.string + + + +-- TRANSFORM + + +toString : Slug -> String +toString (Slug str) = + str diff --git a/test/cases/elm-spa-article-tag.elm b/test/cases/elm-spa-article-tag.elm new file mode 100644 index 0000000..2d2c713 --- /dev/null +++ b/test/cases/elm-spa-article-tag.elm @@ -0,0 +1,42 @@ +module Article.Tag exposing (Tag, list, toString) + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Http +import Json.Decode as Decode exposing (Decoder) + + + +-- TYPES + + +type Tag + = Tag String + + + +-- TRANSFORM + + +toString : Tag -> String +toString (Tag slug) = + slug + + + +-- LIST + + +list : Http.Request (List Tag) +list = + Decode.field "tags" (Decode.list decoder) + |> Api.get Endpoint.tags Nothing + + + +-- SERIALIZATION + + +decoder : Decoder Tag +decoder = + Decode.map Tag Decode.string diff --git a/test/cases/elm-spa-article.elm b/test/cases/elm-spa-article.elm new file mode 100644 index 0000000..fc65faa --- /dev/null +++ b/test/cases/elm-spa-article.elm @@ -0,0 +1,274 @@ +module Article exposing (Article, Full, Preview, author, body, favorite, favoriteButton, fetch, fromPreview, fullDecoder, mapAuthor, metadata, previewDecoder, slug, unfavorite, unfavoriteButton) + +{-| The interface to the Article data structure. + +This includes: + + - The Article type itself + - Ways to make HTTP requests to retrieve and modify articles + - Ways to access information about an article + - Converting between various types + +-} + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article.Body as Body exposing (Body) +import Article.Slug as Slug exposing (Slug) +import Article.Tag as Tag exposing (Tag) +import Author exposing (Author) +import Html exposing (Attribute, Html, i) +import Html.Attributes exposing (class) +import Html.Events exposing (stopPropagationOn) +import Http +import Iso8601 +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (custom, hardcoded, required) +import Json.Encode as Encode +import Markdown +import Profile exposing (Profile) +import Time +import Username as Username exposing (Username) +import Viewer exposing (Viewer) + + + +-- TYPES + + +{-| An article, optionally with an article body. + +To see the difference between { extraInfo : a } and { extraInfo : Maybe Body }, +consider the difference between the "view individual article" page (which +renders one article, including its body) and the "article feed" - +which displays multiple articles, but without bodies. + +This definition for `Article` means we can write: + +viewArticle : Article Full -> Html msg +viewFeed : List (Article Preview) -> Html msg + +This indicates that `viewArticle` requires an article _with a `body` present_, +wereas `viewFeed` accepts articles with no bodies. (We could also have written +it as `List (Article a)` to specify that feeds can accept either articles that +have `body` present or not. Either work, given that feeds do not attempt to +read the `body` field from articles.) + +This is an important distinction, because in Request.Article, the `feed` +function produces `List (Article Preview)` because the API does not return bodies. +Those articles are useful to the feed, but not to the individual article view. + +-} +type Article a + = Article Internals a + + +{-| Metadata about the article - its title, description, and so on. + +Importantly, this module's public API exposes a way to read this metadata, but +not to alter it. This is read-only information! + +If we find ourselves using any particular piece of metadata often, +for example `title`, we could expose a convenience function like this: + +Article.title : Article a -> String + +If you like, it's totally reasonable to expose a function like that for every one +of these fields! + +(Okay, to be completely honest, exposing one function per field is how I prefer +to do it, and that's how I originally wrote this module. However, I'm aware that +this code base has become a common reference point for beginners, and I think it +is _extremely important_ that slapping some "getters and setters" on a record +does not become a habit for anyone who is getting started with Elm. The whole +point of making the Article type opaque is to create guarantees through +_selectively choosing boundaries_ around it. If you aren't selective about +where those boundaries are, and instead expose a "getter and setter" for every +field in the record, the result is an API with no more guarantees than if you'd +exposed the entire record directly! It is so important to me that beginners not +fall into the terrible "getters and setters" trap that I've exposed this +Metadata record instead of exposing a single function for each of its fields, +as I did originally. This record is not a bad way to do it, by any means, +but if this seems at odds with - now you know why! +) + +-} +type alias Metadata = + { description : String + , title : String + , tags : List String + , createdAt : Time.Posix + , favorited : Bool + , favoritesCount : Int + } + + +type alias Internals = + { slug : Slug + , author : Author + , metadata : Metadata + } + + +type Preview + = Preview + + +type Full + = Full Body + + + +-- INFO + + +author : Article a -> Author +author (Article internals _) = + internals.author + + +metadata : Article a -> Metadata +metadata (Article internals _) = + internals.metadata + + +slug : Article a -> Slug +slug (Article internals _) = + internals.slug + + +body : Article Full -> Body +body (Article _ (Full extraInfo)) = + extraInfo + + + +-- TRANSFORM + + +{-| This is the only way you can transform an existing article: +you can change its author (e.g. to follow or unfollow them). +All other article data necessarily comes from the server! + +We can tell this for sure by looking at the types of the exposed functions +in this module. + +-} +mapAuthor : (Author -> Author) -> Article a -> Article a +mapAuthor transform (Article info extras) = + Article { info | author = transform info.author } extras + + +fromPreview : Body -> Article Preview -> Article Full +fromPreview newBody (Article info Preview) = + Article info (Full newBody) + + + +-- SERIALIZATION + + +previewDecoder : Maybe Cred -> Decoder (Article Preview) +previewDecoder maybeCred = + Decode.succeed Article + |> custom (internalsDecoder maybeCred) + |> hardcoded Preview + + +fullDecoder : Maybe Cred -> Decoder (Article Full) +fullDecoder maybeCred = + Decode.succeed Article + |> custom (internalsDecoder maybeCred) + |> required "body" (Decode.map Full Body.decoder) + + +internalsDecoder : Maybe Cred -> Decoder Internals +internalsDecoder maybeCred = + Decode.succeed Internals + |> required "slug" Slug.decoder + |> required "author" (Author.decoder maybeCred) + |> custom metadataDecoder + + +metadataDecoder : Decoder Metadata +metadataDecoder = + Decode.succeed Metadata + |> required "description" (Decode.map (Maybe.withDefault "") (Decode.nullable Decode.string)) + |> required "title" Decode.string + |> required "tagList" (Decode.list Decode.string) + |> required "createdAt" Iso8601.decoder + |> required "favorited" Decode.bool + |> required "favoritesCount" Decode.int + + + +-- SINGLE + + +fetch : Maybe Cred -> Slug -> Http.Request (Article Full) +fetch maybeCred articleSlug = + Decode.field "article" (fullDecoder maybeCred) + |> Api.get (Endpoint.article articleSlug) maybeCred + + + +-- FAVORITE + + +favorite : Slug -> Cred -> Http.Request (Article Preview) +favorite articleSlug cred = + Api.post (Endpoint.favorite articleSlug) (Just cred) Http.emptyBody (faveDecoder cred) + + +unfavorite : Slug -> Cred -> Http.Request (Article Preview) +unfavorite articleSlug cred = + Api.delete (Endpoint.favorite articleSlug) cred Http.emptyBody (faveDecoder cred) + + +faveDecoder : Cred -> Decoder (Article Preview) +faveDecoder cred = + Decode.field "article" (previewDecoder (Just cred)) + + +{-| This is a "build your own element" API. + +You pass it some configuration, followed by a `List (Attribute msg)` and a +`List (Html msg)`, just like any standard Html element. + +-} +favoriteButton : + Cred + -> msg + -> List (Attribute msg) + -> List (Html msg) + -> Html msg +favoriteButton _ msg attrs kids = + toggleFavoriteButton "btn btn-sm btn-outline-primary" msg attrs kids + + +unfavoriteButton : + Cred + -> msg + -> List (Attribute msg) + -> List (Html msg) + -> Html msg +unfavoriteButton _ msg attrs kids = + toggleFavoriteButton "btn btn-sm btn-primary" msg attrs kids + + +toggleFavoriteButton : + String + -> msg + -> List (Attribute msg) + -> List (Html msg) + -> Html msg +toggleFavoriteButton classStr msg attrs kids = + Html.button + (class classStr :: onClickStopPropagation msg :: attrs) + (i [ class "ion-heart" ] [] :: kids) + + +onClickStopPropagation : msg -> Attribute msg +onClickStopPropagation msg = + stopPropagationOn "click" + (Decode.succeed ( msg, True )) diff --git a/test/cases/elm-spa-asset.elm b/test/cases/elm-spa-asset.elm new file mode 100644 index 0000000..72b396d --- /dev/null +++ b/test/cases/elm-spa-asset.elm @@ -0,0 +1,48 @@ +module Asset exposing (Image, defaultAvatar, error, loading, src) + +{-| Assets, such as images, videos, and audio. (We only have images for now.) + +We should never expose asset URLs directly; this module should be in charge of +all of them. One source of truth! + +-} + +import Html exposing (Attribute, Html) +import Html.Attributes as Attr + + +type Image + = Image String + + + +-- IMAGES + + +error : Image +error = + image "error.jpg" + + +loading : Image +loading = + image "loading.svg" + + +defaultAvatar : Image +defaultAvatar = + image "smiley-cyrus.jpg" + + +image : String -> Image +image filename = + Image ("/assets/images/" ++ filename) + + + +-- USING IMAGES + + +src : Image -> Attribute msg +src (Image url) = + Attr.src url diff --git a/test/cases/elm-spa-author.elm b/test/cases/elm-spa-author.elm new file mode 100644 index 0000000..5a19fd9 --- /dev/null +++ b/test/cases/elm-spa-author.elm @@ -0,0 +1,234 @@ +module Author exposing (Author(..), FollowedAuthor, UnfollowedAuthor, decoder, fetch, follow, followButton, profile, requestFollow, requestUnfollow, unfollow, unfollowButton, username, view) + +{-| The author of an Article. It includes a Profile. + +I designed this to make sure the compiler would help me keep these three +possibilities straight when displaying follow buttons and such: + + - I'm following this author. + - I'm not following this author. + - I _can't_ follow this author, because it's me! + +To do this, I defined `Author` a custom type with three variants, one for each +of those possibilities. + +I also made separate types for FollowedAuthor and UnfollowedAuthor. +They are custom type wrappers around Profile, and thier sole purpose is to +help me keep track of which operations are supported. + +For example, consider these functions: + +requestFollow : UnfollowedAuthor -> Cred -> Http.Request Author +requestUnfollow : FollowedAuthor -> Cred -> Http.Request Author + +These types help the compiler prevent several mistakes: + + - Displaying a Follow button for an author the user already follows. + - Displaying an Unfollow button for an author the user already doesn't follow. + - Displaying either button when the author is ourself. + +There are still ways we could mess things up (e.g. make a button that calls Author.unfollow when you click it, but which displays "Follow" to the user) - but this rules out a bunch of potential problems. + +-} + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Html exposing (Html, a, i, text) +import Html.Attributes exposing (attribute, class, href, id, placeholder) +import Html.Events exposing (onClick) +import Http +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (custom, optional, required) +import Json.Encode as Encode exposing (Value) +import Profile exposing (Profile) +import Route exposing (Route) +import Username exposing (Username) +import Viewer exposing (Viewer) + + +{-| An author - either the current user, another user we're following, or +another user we aren't following. + +These distinctions matter because we can only perform "follow" requests for +users we aren't following, we can only perform "unfollow" requests for +users we _are_ following, and we can't perform either for ourselves. + +-} +type Author + = IsFollowing FollowedAuthor + | IsNotFollowing UnfollowedAuthor + | IsViewer Cred Profile + + +{-| An author we're following. +-} +type FollowedAuthor + = FollowedAuthor Username Profile + + +{-| An author we're not following. +-} +type UnfollowedAuthor + = UnfollowedAuthor Username Profile + + +{-| Return an Author's username. +-} +username : Author -> Username +username author = + case author of + IsViewer cred _ -> + Api.username cred + + IsFollowing (FollowedAuthor val _) -> + val + + IsNotFollowing (UnfollowedAuthor val _) -> + val + + +{-| Return an Author's profile. +-} +profile : Author -> Profile +profile author = + case author of + IsViewer _ val -> + val + + IsFollowing (FollowedAuthor _ val) -> + val + + IsNotFollowing (UnfollowedAuthor _ val) -> + val + + + +-- FETCH + + +fetch : Username -> Maybe Cred -> Http.Request Author +fetch uname maybeCred = + Decode.field "profile" (decoder maybeCred) + |> Api.get (Endpoint.profiles uname) maybeCred + + + +-- FOLLOWING + + +follow : UnfollowedAuthor -> FollowedAuthor +follow (UnfollowedAuthor uname prof) = + FollowedAuthor uname prof + + +unfollow : FollowedAuthor -> UnfollowedAuthor +unfollow (FollowedAuthor uname prof) = + UnfollowedAuthor uname prof + + +requestFollow : UnfollowedAuthor -> Cred -> Http.Request Author +requestFollow (UnfollowedAuthor uname _) cred = + Api.post (Endpoint.follow uname) (Just cred) Http.emptyBody (followDecoder cred) + + +requestUnfollow : FollowedAuthor -> Cred -> Http.Request Author +requestUnfollow (FollowedAuthor uname _) cred = + Api.delete (Endpoint.follow uname) + cred + Http.emptyBody + (followDecoder cred) + + +followDecoder : Cred -> Decoder Author +followDecoder cred = + Decode.field "profile" (decoder (Just cred)) + + +followButton : + (Cred -> UnfollowedAuthor -> msg) + -> Cred + -> UnfollowedAuthor + -> Html msg +followButton toMsg cred ((UnfollowedAuthor uname _) as author) = + toggleFollowButton "Follow" + [ "btn-outline-secondary" ] + (toMsg cred author) + uname + + +unfollowButton : + (Cred -> FollowedAuthor -> msg) + -> Cred + -> FollowedAuthor + -> Html msg +unfollowButton toMsg cred ((FollowedAuthor uname _) as author) = + toggleFollowButton "Unfollow" + [ "btn-secondary" ] + (toMsg cred author) + uname + + +toggleFollowButton : String -> List String -> msg -> Username -> Html msg +toggleFollowButton txt extraClasses msgWhenClicked uname = + let + classStr = + "btn btn-sm " ++ String.join " " extraClasses ++ " action-btn" + + caption = + "\u{00A0}" ++ txt ++ " " ++ Username.toString uname + in + Html.button [ class classStr, onClick msgWhenClicked ] + [ i [ class "ion-plus-round" ] [] + , text caption + ] + + + +-- SERIALIZATION + + +decoder : Maybe Cred -> Decoder Author +decoder maybeCred = + Decode.succeed Tuple.pair + |> custom Profile.decoder + |> required "username" Username.decoder + |> Decode.andThen (decodeFromPair maybeCred) + + +decodeFromPair : Maybe Cred -> ( Profile, Username ) -> Decoder Author +decodeFromPair maybeCred ( prof, uname ) = + case maybeCred of + Nothing -> + -- If you're logged out, you can't be following anyone! + Decode.succeed (IsNotFollowing (UnfollowedAuthor uname prof)) + + Just cred -> + if uname == Api.username cred then + Decode.succeed (IsViewer cred prof) + + else + nonViewerDecoder prof uname + + +nonViewerDecoder : Profile -> Username -> Decoder Author +nonViewerDecoder prof uname = + Decode.succeed (authorFromFollowing prof uname) + |> optional "following" Decode.bool False + + +authorFromFollowing : Profile -> Username -> Bool -> Author +authorFromFollowing prof uname isFollowing = + if isFollowing then + IsFollowing (FollowedAuthor uname prof) + + else + IsNotFollowing (UnfollowedAuthor uname prof) + + +{-| View an author. We basically render their username and a link to their +profile, and that's it. +-} +view : Username -> Html msg +view uname = + a [ class "author", Route.href (Route.Profile uname) ] + [ Username.toHtml uname ] diff --git a/test/cases/elm-spa-avatar.elm b/test/cases/elm-spa-avatar.elm new file mode 100644 index 0000000..7ecafb3 --- /dev/null +++ b/test/cases/elm-spa-avatar.elm @@ -0,0 +1,56 @@ +module Avatar exposing (Avatar, decoder, encode, src, toMaybeString) + +import Asset +import Html exposing (Attribute) +import Html.Attributes +import Json.Decode as Decode exposing (Decoder) +import Json.Encode as Encode exposing (Value) + + + +-- TYPES + + +type Avatar + = Avatar (Maybe String) + + + +-- CREATE + + +decoder : Decoder Avatar +decoder = + Decode.map Avatar (Decode.nullable Decode.string) + + + +-- TRANSFORM + + +encode : Avatar -> Value +encode (Avatar maybeUrl) = + case maybeUrl of + Just url -> + Encode.string url + + Nothing -> + Encode.null + + +src : Avatar -> Attribute msg +src (Avatar maybeUrl) = + case maybeUrl of + Nothing -> + Asset.src Asset.defaultAvatar + + Just "" -> + Asset.src Asset.defaultAvatar + + Just url -> + Html.Attributes.src url + + +toMaybeString : Avatar -> Maybe String +toMaybeString (Avatar maybeUrl) = + maybeUrl diff --git a/test/cases/elm-spa-commentid.elm b/test/cases/elm-spa-commentid.elm new file mode 100644 index 0000000..f136e1b --- /dev/null +++ b/test/cases/elm-spa-commentid.elm @@ -0,0 +1,29 @@ +module CommentId exposing (CommentId, decoder, toString) + +import Json.Decode as Decode exposing (Decoder) + + + +-- TYPES + + +type CommentId + = CommentId Int + + + +-- CREATE + + +decoder : Decoder CommentId +decoder = + Decode.map CommentId Decode.int + + + +-- TRANSFORM + + +toString : CommentId -> String +toString (CommentId id) = + String.fromInt id diff --git a/test/cases/elm-spa-email.elm b/test/cases/elm-spa-email.elm new file mode 100644 index 0000000..f696c01 --- /dev/null +++ b/test/cases/elm-spa-email.elm @@ -0,0 +1,45 @@ +module Email exposing (Email, decoder, encode, toString) + +import Json.Decode as Decode exposing (Decoder) +import Json.Encode as Encode exposing (Value) + + +{-| An email address. + +Having this as a custom type that's separate from String makes certain +mistakes impossible. Consider this function: + +updateEmailAddress : Email -> String -> Http.Request +updateEmailAddress email password = ... + +(The server needs your password to confirm that you should be allowed +to update the email address.) + +Because Email is not a type alias for String, but is instead a separate +custom type, it is now impossible to mix up the argument order of the +email and the password. If we do, it won't compile! + +If Email were instead defined as `type alias Email = String`, we could +call updateEmailAddress password email and it would compile (and never +work properly). + +This way, we make it impossible for a bug like that to compile! + +-} +type Email + = Email String + + +toString : Email -> String +toString (Email str) = + str + + +encode : Email -> Value +encode (Email str) = + Encode.string str + + +decoder : Decoder Email +decoder = + Decode.map Email Decode.string diff --git a/test/cases/elm-spa-loading.elm b/test/cases/elm-spa-loading.elm new file mode 100644 index 0000000..2eba301 --- /dev/null +++ b/test/cases/elm-spa-loading.elm @@ -0,0 +1,31 @@ +module Loading exposing (error, icon, slowThreshold) + +{-| A loading spinner icon. +-} + +import Asset +import Html exposing (Attribute, Html) +import Html.Attributes exposing (alt, height, src, width) +import Process +import Task exposing (Task) + + +icon : Html msg +icon = + Html.img + [ Asset.src Asset.loading + , width 64 + , height 64 + , alt "Loading..." + ] + [] + + +error : String -> Html msg +error str = + Html.text ("Error loading " ++ str ++ ".") + + +slowThreshold : Task x () +slowThreshold = + Process.sleep 500 diff --git a/test/cases/elm-spa-log.elm b/test/cases/elm-spa-log.elm new file mode 100644 index 0000000..fe6111e --- /dev/null +++ b/test/cases/elm-spa-log.elm @@ -0,0 +1,20 @@ +module Log exposing (error) + +{-| This is a placeholder API for how we might do logging through +some service like (which is what we use at work). + +Whenever you see Log.error used in this code base, it means +"Something unexpected happened. This is where we would log an +error to our server with some diagnostic info so we could investigate +what happened later." + +(Since this is outside the scope of the RealWorld spec, and is only +a placeholder anyway, I didn't bother making this function accept actual +diagnostic info, authentication tokens, etc.) + +-} + + +error : Cmd msg +error = + Cmd.none diff --git a/test/cases/elm-spa-main.elm b/test/cases/elm-spa-main.elm new file mode 100644 index 0000000..70c62ad --- /dev/null +++ b/test/cases/elm-spa-main.elm @@ -0,0 +1,331 @@ +module Main exposing (main) + +import Api exposing (Cred) +import Article.Slug exposing (Slug) +import Avatar exposing (Avatar) +import Browser exposing (Document) +import Browser.Navigation as Nav +import Html exposing (..) +import Json.Decode as Decode exposing (Value) +import Page exposing (Page) +import Page.Article as Article +import Page.Article.Editor as Editor +import Page.Blank as Blank +import Page.Home as Home +import Page.Login as Login +import Page.NotFound as NotFound +import Page.Profile as Profile +import Page.Register as Register +import Page.Settings as Settings +import Route exposing (Route) +import Session exposing (Session) +import Task +import Time +import Url exposing (Url) +import Username exposing (Username) +import Viewer exposing (Viewer) + + + +-- NOTE: Based on discussions around how asset management features +-- like code splitting and lazy loading have been shaping up, it's possible +-- that most of this file may become unnecessary in a future release of Elm. +-- Avoid putting things in this module unless there is no alternative! +-- See https://discourse.elm-lang.org/t/elm-spa-in-0-19/1800/2 for more. + + +type Model + = Redirect Session + | NotFound Session + | Home Home.Model + | Settings Settings.Model + | Login Login.Model + | Register Register.Model + | Profile Username Profile.Model + | Article Article.Model + | Editor (Maybe Slug) Editor.Model + + + +-- MODEL + + +init : Maybe Viewer -> Url -> Nav.Key -> ( Model, Cmd Msg ) +init maybeViewer url navKey = + changeRouteTo (Route.fromUrl url) + (Redirect (Session.fromViewer navKey maybeViewer)) + + + +-- VIEW + + +view : Model -> Document Msg +view model = + let + viewer = + Session.viewer (toSession model) + + viewPage page toMsg config = + let + { title, body } = + Page.view viewer page config + in + { title = title + , body = List.map (Html.map toMsg) body + } + in + case model of + Redirect _ -> + Page.view viewer Page.Other Blank.view + + NotFound _ -> + Page.view viewer Page.Other NotFound.view + + Settings settings -> + viewPage Page.Other GotSettingsMsg (Settings.view settings) + + Home home -> + viewPage Page.Home GotHomeMsg (Home.view home) + + Login login -> + viewPage Page.Other GotLoginMsg (Login.view login) + + Register register -> + viewPage Page.Other GotRegisterMsg (Register.view register) + + Profile username profile -> + viewPage (Page.Profile username) GotProfileMsg (Profile.view profile) + + Article article -> + viewPage Page.Other GotArticleMsg (Article.view article) + + Editor Nothing editor -> + viewPage Page.NewArticle GotEditorMsg (Editor.view editor) + + Editor (Just _) editor -> + viewPage Page.Other GotEditorMsg (Editor.view editor) + + + +-- UPDATE + + +type Msg + = ChangedUrl Url + | ClickedLink Browser.UrlRequest + | GotHomeMsg Home.Msg + | GotSettingsMsg Settings.Msg + | GotLoginMsg Login.Msg + | GotRegisterMsg Register.Msg + | GotProfileMsg Profile.Msg + | GotArticleMsg Article.Msg + | GotEditorMsg Editor.Msg + | GotSession Session + + +toSession : Model -> Session +toSession page = + case page of + Redirect session -> + session + + NotFound session -> + session + + Home home -> + Home.toSession home + + Settings settings -> + Settings.toSession settings + + Login login -> + Login.toSession login + + Register register -> + Register.toSession register + + Profile _ profile -> + Profile.toSession profile + + Article article -> + Article.toSession article + + Editor _ editor -> + Editor.toSession editor + + +changeRouteTo : Maybe Route -> Model -> ( Model, Cmd Msg ) +changeRouteTo maybeRoute model = + let + session = + toSession model + in + case maybeRoute of + Nothing -> + ( NotFound session, Cmd.none ) + + Just Route.Root -> + ( model, Route.replaceUrl (Session.navKey session) Route.Home ) + + Just Route.Logout -> + ( model, Api.logout ) + + Just Route.NewArticle -> + Editor.initNew session + |> updateWith (Editor Nothing) GotEditorMsg model + + Just (Route.EditArticle slug) -> + Editor.initEdit session slug + |> updateWith (Editor (Just slug)) GotEditorMsg model + + Just Route.Settings -> + Settings.init session + |> updateWith Settings GotSettingsMsg model + + Just Route.Home -> + Home.init session + |> updateWith Home GotHomeMsg model + + Just Route.Login -> + Login.init session + |> updateWith Login GotLoginMsg model + + Just Route.Register -> + Register.init session + |> updateWith Register GotRegisterMsg model + + Just (Route.Profile username) -> + Profile.init session username + |> updateWith (Profile username) GotProfileMsg model + + Just (Route.Article slug) -> + Article.init session slug + |> updateWith Article GotArticleMsg model + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case ( msg, model ) of + ( ClickedLink urlRequest, _ ) -> + case urlRequest of + Browser.Internal url -> + case url.fragment of + Nothing -> + -- If we got a link that didn't include a fragment, + -- it's from one of those (href "") attributes that + -- we have to include to make the RealWorld CSS work. + -- + -- In an application doing path routing instead of + -- fragment-based routing, this entire + -- `case url.fragment of` expression this comment + -- is inside would be unnecessary. + ( model, Cmd.none ) + + Just _ -> + ( model + , Nav.pushUrl (Session.navKey (toSession model)) (Url.toString url) + ) + + Browser.External href -> + ( model + , Nav.load href + ) + + ( ChangedUrl url, _ ) -> + changeRouteTo (Route.fromUrl url) model + + ( GotSettingsMsg subMsg, Settings settings ) -> + Settings.update subMsg settings + |> updateWith Settings GotSettingsMsg model + + ( GotLoginMsg subMsg, Login login ) -> + Login.update subMsg login + |> updateWith Login GotLoginMsg model + + ( GotRegisterMsg subMsg, Register register ) -> + Register.update subMsg register + |> updateWith Register GotRegisterMsg model + + ( GotHomeMsg subMsg, Home home ) -> + Home.update subMsg home + |> updateWith Home GotHomeMsg model + + ( GotProfileMsg subMsg, Profile username profile ) -> + Profile.update subMsg profile + |> updateWith (Profile username) GotProfileMsg model + + ( GotArticleMsg subMsg, Article article ) -> + Article.update subMsg article + |> updateWith Article GotArticleMsg model + + ( GotEditorMsg subMsg, Editor slug editor ) -> + Editor.update subMsg editor + |> updateWith (Editor slug) GotEditorMsg model + + ( GotSession session, Redirect _ ) -> + ( Redirect session + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + ( _, _ ) -> + -- Disregard messages that arrived for the wrong page. + ( model, Cmd.none ) + + +updateWith : (subModel -> Model) -> (subMsg -> Msg) -> Model -> ( subModel, Cmd subMsg ) -> ( Model, Cmd Msg ) +updateWith toModel toMsg model ( subModel, subCmd ) = + ( toModel subModel + , Cmd.map toMsg subCmd + ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + case model of + NotFound _ -> + Sub.none + + Redirect _ -> + Session.changes GotSession (Session.navKey (toSession model)) + + Settings settings -> + Sub.map GotSettingsMsg (Settings.subscriptions settings) + + Home home -> + Sub.map GotHomeMsg (Home.subscriptions home) + + Login login -> + Sub.map GotLoginMsg (Login.subscriptions login) + + Register register -> + Sub.map GotRegisterMsg (Register.subscriptions register) + + Profile _ profile -> + Sub.map GotProfileMsg (Profile.subscriptions profile) + + Article article -> + Sub.map GotArticleMsg (Article.subscriptions article) + + Editor _ editor -> + Sub.map GotEditorMsg (Editor.subscriptions editor) + + + +-- MAIN + + +main : Program Value Model Msg +main = + Api.application Viewer.decoder + { init = init + , onUrlChange = ChangedUrl + , onUrlRequest = ClickedLink + , subscriptions = subscriptions + , update = update + , view = view + } diff --git a/test/cases/elm-spa-page-article-editor.elm b/test/cases/elm-spa-page-article-editor.elm new file mode 100644 index 0000000..d339cbf --- /dev/null +++ b/test/cases/elm-spa-page-article-editor.elm @@ -0,0 +1,600 @@ +module Page.Article.Editor exposing (Model, Msg, initEdit, initNew, subscriptions, toSession, update, view) + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article exposing (Article, Full) +import Article.Body exposing (Body) +import Article.Slug as Slug exposing (Slug) +import Browser.Navigation as Nav +import Html exposing (..) +import Html.Attributes exposing (attribute, class, disabled, href, id, placeholder, type_, value) +import Html.Events exposing (onInput, onSubmit) +import Http +import Json.Decode as Decode +import Json.Encode as Encode +import Loading +import Page +import Profile exposing (Profile) +import Route +import Session exposing (Session) +import Task exposing (Task) +import Time + + + +-- MODEL + + +type alias Model = + { session : Session + , status : Status + } + + +type + Status + -- Edit Article + = Loading Slug + | LoadingSlowly Slug + | LoadingFailed Slug + | Saving Slug Form + | Editing Slug (List Problem) Form + -- New Article + | EditingNew (List Problem) Form + | Creating Form + + +type Problem + = InvalidEntry ValidatedField String + | ServerError String + + +type alias Form = + { title : String + , body : String + , description : String + , tags : String + } + + +initNew : Session -> ( Model, Cmd msg ) +initNew session = + ( { session = session + , status = + EditingNew [] + { title = "" + , body = "" + , description = "" + , tags = "" + } + } + , Cmd.none + ) + + +initEdit : Session -> Slug -> ( Model, Cmd Msg ) +initEdit session slug = + ( { session = session + , status = Loading slug + } + , Cmd.batch + [ Article.fetch (Session.cred session) slug + |> Http.toTask + -- If init fails, store the slug that failed in the msg, so we can + -- at least have it later to display the page's title properly! + |> Task.mapError (\httpError -> ( slug, httpError )) + |> Task.attempt CompletedArticleLoad + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + { title = + case getSlug model.status of + Just slug -> + "Edit Article - " ++ Slug.toString slug + + Nothing -> + "New Article" + , content = + case Session.cred model.session of + Just cred -> + viewAuthenticated cred model + + Nothing -> + text "Sign in to edit this article." + } + + +viewProblems : List Problem -> Html msg +viewProblems problems = + ul [ class "error-messages" ] + (List.map viewProblem problems) + + +viewProblem : Problem -> Html msg +viewProblem problem = + let + errorMessage = + case problem of + InvalidEntry _ message -> + message + + ServerError message -> + message + in + li [] [ text errorMessage ] + + +viewAuthenticated : Cred -> Model -> Html Msg +viewAuthenticated cred model = + let + formHtml = + case model.status of + Loading _ -> + [] + + LoadingSlowly _ -> + [ Loading.icon ] + + Saving slug form -> + [ viewForm cred form (editArticleSaveButton [ disabled True ]) ] + + Creating form -> + [ viewForm cred form (newArticleSaveButton [ disabled True ]) ] + + Editing slug problems form -> + [ viewProblems problems + , viewForm cred form (editArticleSaveButton []) + ] + + EditingNew problems form -> + [ viewProblems problems + , viewForm cred form (newArticleSaveButton []) + ] + + LoadingFailed _ -> + [ text "Article failed to load." ] + in + div [ class "editor-page" ] + [ div [ class "container page" ] + [ div [ class "row" ] + [ div [ class "col-md-10 offset-md-1 col-xs-12" ] + formHtml + ] + ] + ] + + +viewForm : Cred -> Form -> Html Msg -> Html Msg +viewForm cred fields saveButton = + Html.form [ onSubmit (ClickedSave cred) ] + [ fieldset [] + [ fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , placeholder "Article Title" + , onInput EnteredTitle + , value fields.title + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control" + , placeholder "What's this article about?" + , onInput EnteredDescription + , value fields.description + ] + [] + ] + , fieldset [ class "form-group" ] + [ textarea + [ class "form-control" + , placeholder "Write your article (in markdown)" + , attribute "rows" "8" + , onInput EnteredBody + , value fields.body + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control" + , placeholder "Enter tags" + , onInput EnteredTags + , value fields.tags + ] + [] + ] + , saveButton + ] + ] + + +editArticleSaveButton : List (Attribute msg) -> Html msg +editArticleSaveButton extraAttrs = + saveArticleButton "Update Article" extraAttrs + + +newArticleSaveButton : List (Attribute msg) -> Html msg +newArticleSaveButton extraAttrs = + saveArticleButton "Publish Article" extraAttrs + + +saveArticleButton : String -> List (Attribute msg) -> Html msg +saveArticleButton caption extraAttrs = + button (class "btn btn-lg pull-xs-right btn-primary" :: extraAttrs) + [ text caption ] + + + +-- UPDATE + + +type Msg + = ClickedSave Cred + | EnteredBody String + | EnteredDescription String + | EnteredTags String + | EnteredTitle String + | CompletedCreate (Result Http.Error (Article Full)) + | CompletedEdit (Result Http.Error (Article Full)) + | CompletedArticleLoad (Result ( Slug, Http.Error ) (Article Full)) + | GotSession Session + | PassedSlowLoadThreshold + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ClickedSave cred -> + model.status + |> save cred + |> Tuple.mapFirst (\status -> { model | status = status }) + + EnteredTitle title -> + updateForm (\form -> { form | title = title }) model + + EnteredDescription description -> + updateForm (\form -> { form | description = description }) model + + EnteredTags tags -> + updateForm (\form -> { form | tags = tags }) model + + EnteredBody body -> + updateForm (\form -> { form | body = body }) model + + CompletedCreate (Ok article) -> + ( model + , Route.Article (Article.slug article) + |> Route.replaceUrl (Session.navKey model.session) + ) + + CompletedCreate (Err error) -> + ( { model | status = savingError error model.status } + , Cmd.none + ) + + CompletedEdit (Ok article) -> + ( model + , Route.Article (Article.slug article) + |> Route.replaceUrl (Session.navKey model.session) + ) + + CompletedEdit (Err error) -> + ( { model | status = savingError error model.status } + , Cmd.none + ) + + CompletedArticleLoad (Err ( slug, error )) -> + ( { model | status = LoadingFailed slug } + , Cmd.none + ) + + CompletedArticleLoad (Ok article) -> + let + { title, description, tags } = + Article.metadata article + + status = + Editing (Article.slug article) + [] + { title = title + , body = Article.Body.toMarkdownString (Article.body article) + , description = description + , tags = String.join " " tags + } + in + ( { model | status = status } + , Cmd.none + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + PassedSlowLoadThreshold -> + let + -- If any data is still Loading, change it to LoadingSlowly + -- so `view` knows to render a spinner. + status = + case model.status of + Loading slug -> + LoadingSlowly slug + + other -> + other + in + ( { model | status = status }, Cmd.none ) + + +save : Cred -> Status -> ( Status, Cmd Msg ) +save cred status = + case status of + Editing slug _ form -> + case validate form of + Ok validForm -> + ( Saving slug form + , edit slug validForm cred + |> Http.send CompletedEdit + ) + + Err problems -> + ( Editing slug problems form + , Cmd.none + ) + + EditingNew _ form -> + case validate form of + Ok validForm -> + ( Creating form + , create validForm cred + |> Http.send CompletedCreate + ) + + Err problems -> + ( EditingNew problems form + , Cmd.none + ) + + _ -> + -- We're in a state where saving is not allowed. + -- We tried to prevent getting here by disabling the Save + -- button, but somehow the user got here anyway! + -- + -- If we had an error logging service, we would send + -- something to it here! + ( status, Cmd.none ) + + +savingError : Http.Error -> Status -> Status +savingError error status = + let + problems = + [ ServerError "Error saving article" ] + in + case status of + Saving slug form -> + Editing slug problems form + + Creating form -> + EditingNew problems form + + _ -> + status + + +{-| Helper function for `update`. Updates the form, if there is one, +and returns Cmd.none. + +Useful for recording form fields! + +This could also log errors to the server if we are trying to record things in +the form and we don't actually have a form. + +-} +updateForm : (Form -> Form) -> Model -> ( Model, Cmd Msg ) +updateForm transform model = + let + newModel = + case model.status of + Loading _ -> + model + + LoadingSlowly _ -> + model + + LoadingFailed _ -> + model + + Saving slug form -> + { model | status = Saving slug (transform form) } + + Editing slug errors form -> + { model | status = Editing slug errors (transform form) } + + EditingNew errors form -> + { model | status = EditingNew errors (transform form) } + + Creating form -> + { model | status = Creating (transform form) } + in + ( newModel, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey 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 + = Title + | Body + + +fieldsToValidate : List ValidatedField +fieldsToValidate = + [ Title + , Body + ] + + +{-| 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 + Title -> + if String.isEmpty form.title then + [ "title can't be blank." ] + + else + [] + + Body -> + if String.isEmpty form.body then + [ "body can't be blank." ] + + 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 + { title = String.trim form.title + , body = String.trim form.body + , description = String.trim form.description + , tags = String.trim form.tags + } + + + +-- HTTP + + +create : TrimmedForm -> Cred -> Http.Request (Article Full) +create (Trimmed form) cred = + let + article = + Encode.object + [ ( "title", Encode.string form.title ) + , ( "description", Encode.string form.description ) + , ( "body", Encode.string form.body ) + , ( "tagList", Encode.list Encode.string (tagsFromString form.tags) ) + ] + + body = + Encode.object [ ( "article", article ) ] + |> Http.jsonBody + in + Decode.field "article" (Article.fullDecoder (Just cred)) + |> Api.post (Endpoint.articles []) (Just cred) body + + +tagsFromString : String -> List String +tagsFromString str = + String.split " " str + |> List.map String.trim + |> List.filter (not << String.isEmpty) + + +edit : Slug -> TrimmedForm -> Cred -> Http.Request (Article Full) +edit articleSlug (Trimmed form) cred = + let + article = + Encode.object + [ ( "title", Encode.string form.title ) + , ( "description", Encode.string form.description ) + , ( "body", Encode.string form.body ) + ] + + body = + Encode.object [ ( "article", article ) ] + |> Http.jsonBody + in + Decode.field "article" (Article.fullDecoder (Just cred)) + |> Api.put (Endpoint.article articleSlug) cred body + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session + + + +-- INTERNAL + + +{-| Used for setting the page's title. +-} +getSlug : Status -> Maybe Slug +getSlug status = + case status of + Loading slug -> + Just slug + + LoadingSlowly slug -> + Just slug + + LoadingFailed slug -> + Just slug + + Saving slug _ -> + Just slug + + Editing slug _ _ -> + Just slug + + EditingNew _ _ -> + Nothing + + Creating _ -> + Nothing diff --git a/test/cases/elm-spa-page-article.elm b/test/cases/elm-spa-page-article.elm new file mode 100644 index 0000000..1ef0d6e --- /dev/null +++ b/test/cases/elm-spa-page-article.elm @@ -0,0 +1,586 @@ +module Page.Article exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| Viewing an individual article. +-} + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article exposing (Article, Full, Preview) +import Article.Body exposing (Body) +import Article.Comment as Comment exposing (Comment) +import Article.Slug as Slug exposing (Slug) +import Author exposing (Author(..), FollowedAuthor, UnfollowedAuthor) +import Avatar +import Browser.Navigation as Nav +import CommentId exposing (CommentId) +import Html exposing (..) +import Html.Attributes exposing (attribute, class, disabled, href, id, placeholder, value) +import Html.Events exposing (onClick, onInput, onSubmit) +import Http +import Json.Decode as Decode +import Loading +import Log +import Page +import Profile exposing (Profile) +import Route +import Session exposing (Session) +import Task exposing (Task) +import Time +import Timestamp +import Username exposing (Username) +import Viewer exposing (Viewer) + + + +-- MODEL + + +type alias Model = + { session : Session + , timeZone : Time.Zone + , errors : List String + + -- Loaded independently from server + , comments : Status ( CommentText, List Comment ) + , article : Status (Article Full) + } + + +type Status a + = Loading + | LoadingSlowly + | Loaded a + | Failed + + +type CommentText + = Editing String + | Sending String + + +init : Session -> Slug -> ( Model, Cmd Msg ) +init session slug = + let + maybeCred = + Session.cred session + in + ( { session = session + , timeZone = Time.utc + , errors = [] + , comments = Loading + , article = Loading + } + , Cmd.batch + [ Article.fetch maybeCred slug + |> Http.send CompletedLoadArticle + , Comment.list maybeCred slug + |> Http.send CompletedLoadComments + , Task.perform GotTimeZone Time.here + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + case model.article of + Loaded article -> + let + { title } = + Article.metadata article + + author = + Article.author article + + avatar = + Profile.avatar (Author.profile author) + + slug = + Article.slug article + + profile = + Author.profile author + + buttons = + case Session.cred model.session of + Just cred -> + viewButtons cred article author + + Nothing -> + [] + in + { title = title + , content = + div [ class "article-page" ] + [ div [ class "banner" ] + [ div [ class "container" ] + [ h1 [] [ text title ] + , div [ class "article-meta" ] <| + List.append + [ a [ Route.href (Route.Profile (Author.username author)) ] + [ img [ Avatar.src (Profile.avatar profile) ] [] ] + , div [ class "info" ] + [ Author.view (Author.username author) + , Timestamp.view model.timeZone (Article.metadata article).createdAt + ] + ] + buttons + , Page.viewErrors ClickedDismissErrors model.errors + ] + ] + , div [ class "container page" ] + [ div [ class "row article-content" ] + [ div [ class "col-md-12" ] + [ Article.Body.toHtml (Article.body article) [] ] + ] + , hr [] [] + , div [ class "article-actions" ] + [ div [ class "article-meta" ] <| + List.append + [ a [ Route.href (Route.Profile (Author.username author)) ] + [ img [ Avatar.src avatar ] [] ] + , div [ class "info" ] + [ Author.view (Author.username author) + , Timestamp.view model.timeZone (Article.metadata article).createdAt + ] + ] + buttons + ] + , div [ class "row" ] + [ div [ class "col-xs-12 col-md-8 offset-md-2" ] <| + -- Don't render the comments until the article has loaded! + case model.comments of + Loading -> + [] + + LoadingSlowly -> + [ Loading.icon ] + + Loaded ( commentText, comments ) -> + -- Don't let users add comments until they can + -- see the existing comments! Otherwise you + -- may be about to repeat something that's + -- already been said. + viewAddComment slug commentText (Session.viewer model.session) + :: List.map (viewComment model.timeZone slug) comments + + Failed -> + [ Loading.error "comments" ] + ] + ] + ] + } + + Loading -> + { title = "Article", content = text "" } + + LoadingSlowly -> + { title = "Article", content = Loading.icon } + + Failed -> + { title = "Article", content = Loading.error "article" } + + +viewAddComment : Slug -> CommentText -> Maybe Viewer -> Html Msg +viewAddComment slug commentText maybeViewer = + case maybeViewer of + Just viewer -> + let + avatar = + Viewer.avatar viewer + + cred = + Viewer.cred viewer + + ( commentStr, buttonAttrs ) = + case commentText of + Editing str -> + ( str, [] ) + + Sending str -> + ( str, [ disabled True ] ) + in + Html.form [ class "card comment-form", onSubmit (ClickedPostComment cred slug) ] + [ div [ class "card-block" ] + [ textarea + [ class "form-control" + , placeholder "Write a comment..." + , attribute "rows" "3" + , onInput EnteredCommentText + , value commentStr + ] + [] + ] + , div [ class "card-footer" ] + [ img [ class "comment-author-img", Avatar.src avatar ] [] + , button + (class "btn btn-sm btn-primary" :: buttonAttrs) + [ text "Post Comment" ] + ] + ] + + Nothing -> + p [] + [ a [ Route.href Route.Login ] [ text "Sign in" ] + , text " or " + , a [ Route.href Route.Register ] [ text "sign up" ] + , text " to comment." + ] + + +viewButtons : Cred -> Article Full -> Author -> List (Html Msg) +viewButtons cred article author = + case author of + IsFollowing followedAuthor -> + [ Author.unfollowButton ClickedUnfollow cred followedAuthor + , text " " + , favoriteButton cred article + ] + + IsNotFollowing unfollowedAuthor -> + [ Author.followButton ClickedFollow cred unfollowedAuthor + , text " " + , favoriteButton cred article + ] + + IsViewer _ _ -> + [ editButton article + , text " " + , deleteButton cred article + ] + + +viewComment : Time.Zone -> Slug -> Comment -> Html Msg +viewComment timeZone slug comment = + let + author = + Comment.author comment + + profile = + Author.profile author + + authorUsername = + Author.username author + + deleteCommentButton = + case author of + IsViewer cred _ -> + let + msg = + ClickedDeleteComment cred slug (Comment.id comment) + in + span + [ class "mod-options" + , onClick msg + ] + [ i [ class "ion-trash-a" ] [] ] + + _ -> + -- You can't delete other peoples' comments! + text "" + + timestamp = + Timestamp.format timeZone (Comment.createdAt comment) + in + div [ class "card" ] + [ div [ class "card-block" ] + [ p [ class "card-text" ] [ text (Comment.body comment) ] ] + , div [ class "card-footer" ] + [ a [ class "comment-author", href "" ] + [ img [ class "comment-author-img", Avatar.src (Profile.avatar profile) ] [] + , text " " + ] + , text " " + , a [ class "comment-author", Route.href (Route.Profile authorUsername) ] + [ text (Username.toString authorUsername) ] + , span [ class "date-posted" ] [ text timestamp ] + , deleteCommentButton + ] + ] + + + +-- UPDATE + + +type Msg + = ClickedDeleteArticle Cred Slug + | ClickedDeleteComment Cred Slug CommentId + | ClickedDismissErrors + | ClickedFavorite Cred Slug Body + | ClickedUnfavorite Cred Slug Body + | ClickedFollow Cred UnfollowedAuthor + | ClickedUnfollow Cred FollowedAuthor + | ClickedPostComment Cred Slug + | EnteredCommentText String + | CompletedLoadArticle (Result Http.Error (Article Full)) + | CompletedLoadComments (Result Http.Error (List Comment)) + | CompletedDeleteArticle (Result Http.Error ()) + | CompletedDeleteComment CommentId (Result Http.Error ()) + | CompletedFavoriteChange (Result Http.Error (Article Full)) + | CompletedFollowChange (Result Http.Error Author) + | CompletedPostComment (Result Http.Error Comment) + | GotTimeZone Time.Zone + | GotSession Session + | PassedSlowLoadThreshold + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ClickedDismissErrors -> + ( { model | errors = [] }, Cmd.none ) + + ClickedFavorite cred slug body -> + ( model, fave Article.favorite cred slug body ) + + ClickedUnfavorite cred slug body -> + ( model, fave Article.unfavorite cred slug body ) + + CompletedLoadArticle (Ok article) -> + ( { model | article = Loaded article }, Cmd.none ) + + CompletedLoadArticle (Err error) -> + ( { model | article = Failed } + , Log.error + ) + + CompletedLoadComments (Ok comments) -> + ( { model | comments = Loaded ( Editing "", comments ) }, Cmd.none ) + + CompletedLoadComments (Err error) -> + ( { model | article = Failed }, Log.error ) + + CompletedFavoriteChange (Ok newArticle) -> + ( { model | article = Loaded newArticle }, Cmd.none ) + + CompletedFavoriteChange (Err error) -> + ( { model | errors = Api.addServerError model.errors } + , Log.error + ) + + ClickedUnfollow cred followedAuthor -> + ( model + , Author.requestUnfollow followedAuthor cred + |> Http.send CompletedFollowChange + ) + + ClickedFollow cred unfollowedAuthor -> + ( model + , Author.requestFollow unfollowedAuthor cred + |> Http.send CompletedFollowChange + ) + + CompletedFollowChange (Ok newAuthor) -> + case model.article of + Loaded article -> + ( { model | article = Loaded (Article.mapAuthor (\_ -> newAuthor) article) }, Cmd.none ) + + _ -> + ( model, Log.error ) + + CompletedFollowChange (Err error) -> + ( { model | errors = Api.addServerError model.errors } + , Log.error + ) + + EnteredCommentText str -> + case model.comments of + Loaded ( Editing _, comments ) -> + -- You can only edit comment text once comments have loaded + -- successfully, and when the comment is not currently + -- being submitted. + ( { model | comments = Loaded ( Editing str, comments ) } + , Cmd.none + ) + + _ -> + ( model, Log.error ) + + ClickedPostComment cred slug -> + case model.comments of + Loaded ( Editing "", comments ) -> + -- No posting empty comments! + -- We don't use Log.error here because this isn't an error, + -- it just doesn't do anything. + ( model, Cmd.none ) + + Loaded ( Editing str, comments ) -> + ( { model | comments = Loaded ( Sending str, comments ) } + , cred + |> Comment.post slug str + |> Http.send CompletedPostComment + ) + + _ -> + -- Either we have no comment to post, or there's already + -- one in the process of being posted, or we don't have + -- a valid article, in which case how did we post this? + ( model, Log.error ) + + CompletedPostComment (Ok comment) -> + case model.comments of + Loaded ( _, comments ) -> + ( { model | comments = Loaded ( Editing "", comment :: comments ) } + , Cmd.none + ) + + _ -> + ( model, Log.error ) + + CompletedPostComment (Err error) -> + ( { model | errors = Api.addServerError model.errors } + , Log.error + ) + + ClickedDeleteComment cred slug id -> + ( model + , cred + |> Comment.delete slug id + |> Http.send (CompletedDeleteComment id) + ) + + CompletedDeleteComment id (Ok ()) -> + case model.comments of + Loaded ( commentText, comments ) -> + ( { model | comments = Loaded ( commentText, withoutComment id comments ) } + , Cmd.none + ) + + _ -> + ( model, Log.error ) + + CompletedDeleteComment id (Err error) -> + ( { model | errors = Api.addServerError model.errors } + , Log.error + ) + + ClickedDeleteArticle cred slug -> + ( model + , delete slug cred + |> Http.send CompletedDeleteArticle + ) + + CompletedDeleteArticle (Ok ()) -> + ( model, Route.replaceUrl (Session.navKey model.session) Route.Home ) + + CompletedDeleteArticle (Err error) -> + ( { model | errors = Api.addServerError model.errors } + , Log.error + ) + + GotTimeZone tz -> + ( { model | timeZone = tz }, Cmd.none ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + PassedSlowLoadThreshold -> + let + -- If any data is still Loading, change it to LoadingSlowly + -- so `view` knows to render a spinner. + article = + case model.article of + Loading -> + LoadingSlowly + + other -> + other + + comments = + case model.comments of + Loading -> + LoadingSlowly + + other -> + other + in + ( { model | article = article, comments = comments }, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- HTTP + + +delete : Slug -> Cred -> Http.Request () +delete slug cred = + Api.delete (Endpoint.article slug) cred Http.emptyBody (Decode.succeed ()) + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session + + + +-- INTERNAL + + +fave : (Slug -> Cred -> Http.Request (Article Preview)) -> Cred -> Slug -> Body -> Cmd Msg +fave toRequest cred slug body = + toRequest slug cred + |> Http.toTask + |> Task.map (Article.fromPreview body) + |> Task.attempt CompletedFavoriteChange + + +withoutComment : CommentId -> List Comment -> List Comment +withoutComment id list = + List.filter (\comment -> Comment.id comment /= id) list + + +favoriteButton : Cred -> Article Full -> Html Msg +favoriteButton cred article = + let + { favoritesCount, favorited } = + Article.metadata article + + slug = + Article.slug article + + body = + Article.body article + + kids = + [ text (" Favorite Article (" ++ String.fromInt favoritesCount ++ ")") ] + in + if favorited then + Article.unfavoriteButton cred (ClickedUnfavorite cred slug body) [] kids + + else + Article.favoriteButton cred (ClickedFavorite cred slug body) [] kids + + +deleteButton : Cred -> Article a -> Html Msg +deleteButton cred article = + let + msg = + ClickedDeleteArticle cred (Article.slug article) + in + button [ class "btn btn-outline-danger btn-sm", onClick msg ] + [ i [ class "ion-trash-a" ] [], text " Delete Article" ] + + +editButton : Article a -> Html Msg +editButton article = + a [ class "btn btn-outline-secondary btn-sm", Route.href (Route.EditArticle (Article.slug article)) ] + [ i [ class "ion-edit" ] [], text " Edit Article" ] diff --git a/test/cases/elm-spa-page-blank.elm b/test/cases/elm-spa-page-blank.elm new file mode 100644 index 0000000..3ae45a3 --- /dev/null +++ b/test/cases/elm-spa-page-blank.elm @@ -0,0 +1,10 @@ +module Page.Blank exposing (view) + +import Html exposing (Html) + + +view : { title : String, content : Html msg } +view = + { title = "" + , content = Html.text "" + } diff --git a/test/cases/elm-spa-page-home.elm b/test/cases/elm-spa-page-home.elm new file mode 100644 index 0000000..9008a83 --- /dev/null +++ b/test/cases/elm-spa-page-home.elm @@ -0,0 +1,395 @@ +module Page.Home exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| The homepage. You can get here via either the / or /#/ routes. +-} + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article exposing (Article, Preview) +import Article.Feed as Feed +import Article.Tag as Tag exposing (Tag) +import Browser.Dom as Dom +import Html exposing (..) +import Html.Attributes exposing (attribute, class, classList, href, id, placeholder) +import Html.Events exposing (onClick) +import Http +import Loading +import Log +import Page +import PaginatedList exposing (PaginatedList) +import Session exposing (Session) +import Task exposing (Task) +import Time +import Url.Builder +import Username exposing (Username) + + + +-- MODEL + + +type alias Model = + { session : Session + , timeZone : Time.Zone + , feedTab : FeedTab + , feedPage : Int + + -- Loaded independently from server + , tags : Status (List Tag) + , feed : Status Feed.Model + } + + +type Status a + = Loading + | LoadingSlowly + | Loaded a + | Failed + + +type FeedTab + = YourFeed Cred + | GlobalFeed + | TagFeed Tag + + +init : Session -> ( Model, Cmd Msg ) +init session = + let + feedTab = + case Session.cred session of + Just cred -> + YourFeed cred + + Nothing -> + GlobalFeed + + loadTags = + Http.toTask Tag.list + in + ( { session = session + , timeZone = Time.utc + , feedTab = feedTab + , feedPage = 1 + , tags = Loading + , feed = Loading + } + , Cmd.batch + [ fetchFeed session feedTab 1 + |> Task.attempt CompletedFeedLoad + , Tag.list + |> Http.send CompletedTagsLoad + , Task.perform GotTimeZone Time.here + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + { title = "Conduit" + , content = + div [ class "home-page" ] + [ viewBanner + , div [ class "container page" ] + [ div [ class "row" ] + [ div [ class "col-md-9" ] <| + case model.feed of + Loaded feed -> + [ div [ class "feed-toggle" ] <| + List.concat + [ [ viewTabs + (Session.cred model.session) + model.feedTab + ] + , Feed.viewArticles model.timeZone feed + |> List.map (Html.map GotFeedMsg) + , [ Feed.viewPagination ClickedFeedPage model.feedPage feed ] + ] + ] + + Loading -> + [] + + LoadingSlowly -> + [ Loading.icon ] + + Failed -> + [ Loading.error "feed" ] + , div [ class "col-md-3" ] <| + case model.tags of + Loaded tags -> + [ div [ class "sidebar" ] <| + [ p [] [ text "Popular Tags" ] + , viewTags tags + ] + ] + + Loading -> + [] + + LoadingSlowly -> + [ Loading.icon ] + + Failed -> + [ Loading.error "tags" ] + ] + ] + ] + } + + +viewBanner : Html msg +viewBanner = + div [ class "banner" ] + [ div [ class "container" ] + [ h1 [ class "logo-font" ] [ text "conduit" ] + , p [] [ text "A place to share your knowledge." ] + ] + ] + + + +-- TABS + + +viewTabs : Maybe Cred -> FeedTab -> Html Msg +viewTabs maybeCred tab = + case tab of + YourFeed cred -> + Feed.viewTabs [] (yourFeed cred) [ globalFeed ] + + GlobalFeed -> + let + otherTabs = + case maybeCred of + Just cred -> + [ yourFeed cred ] + + Nothing -> + [] + in + Feed.viewTabs otherTabs globalFeed [] + + TagFeed tag -> + let + otherTabs = + case maybeCred of + Just cred -> + [ yourFeed cred, globalFeed ] + + Nothing -> + [ globalFeed ] + in + Feed.viewTabs otherTabs (tagFeed tag) [] + + +yourFeed : Cred -> ( String, Msg ) +yourFeed cred = + ( "Your Feed", ClickedTab (YourFeed cred) ) + + +globalFeed : ( String, Msg ) +globalFeed = + ( "Global Feed", ClickedTab GlobalFeed ) + + +tagFeed : Tag -> ( String, Msg ) +tagFeed tag = + ( "#" ++ Tag.toString tag, ClickedTab (TagFeed tag) ) + + + +-- TAGS + + +viewTags : List Tag -> Html Msg +viewTags tags = + div [ class "tag-list" ] (List.map viewTag tags) + + +viewTag : Tag -> Html Msg +viewTag tagName = + a + [ class "tag-pill tag-default" + , onClick (ClickedTag tagName) + + -- The RealWorld CSS requires an href to work properly. + , href "" + ] + [ text (Tag.toString tagName) ] + + + +-- UPDATE + + +type Msg + = ClickedTag Tag + | ClickedTab FeedTab + | ClickedFeedPage Int + | CompletedFeedLoad (Result Http.Error Feed.Model) + | CompletedTagsLoad (Result Http.Error (List Tag)) + | GotTimeZone Time.Zone + | GotFeedMsg Feed.Msg + | GotSession Session + | PassedSlowLoadThreshold + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ClickedTag tag -> + let + feedTab = + TagFeed tag + in + ( { model | feedTab = feedTab } + , fetchFeed model.session feedTab 1 + |> Task.attempt CompletedFeedLoad + ) + + ClickedTab tab -> + ( { model | feedTab = tab } + , fetchFeed model.session tab 1 + |> Task.attempt CompletedFeedLoad + ) + + ClickedFeedPage page -> + ( { model | feedPage = page } + , fetchFeed model.session model.feedTab page + |> Task.andThen (\feed -> Task.map (\_ -> feed) scrollToTop) + |> Task.attempt CompletedFeedLoad + ) + + CompletedFeedLoad (Ok feed) -> + ( { model | feed = Loaded feed }, Cmd.none ) + + CompletedFeedLoad (Err error) -> + ( { model | feed = Failed }, Cmd.none ) + + CompletedTagsLoad (Ok tags) -> + ( { model | tags = Loaded tags }, Cmd.none ) + + CompletedTagsLoad (Err error) -> + ( { model | tags = Failed } + , Log.error + ) + + GotFeedMsg subMsg -> + case model.feed of + Loaded feed -> + let + ( newFeed, subCmd ) = + Feed.update (Session.cred model.session) subMsg feed + in + ( { model | feed = Loaded newFeed } + , Cmd.map GotFeedMsg subCmd + ) + + Loading -> + ( model, Log.error ) + + LoadingSlowly -> + ( model, Log.error ) + + Failed -> + ( model, Log.error ) + + GotTimeZone tz -> + ( { model | timeZone = tz }, Cmd.none ) + + GotSession session -> + ( { model | session = session }, Cmd.none ) + + PassedSlowLoadThreshold -> + let + -- If any data is still Loading, change it to LoadingSlowly + -- so `view` knows to render a spinner. + feed = + case model.feed of + Loading -> + LoadingSlowly + + other -> + other + + tags = + case model.tags of + Loading -> + LoadingSlowly + + other -> + other + in + ( { model | feed = feed, tags = tags }, Cmd.none ) + + + +-- HTTP + + +fetchFeed : Session -> FeedTab -> Int -> Task Http.Error Feed.Model +fetchFeed session feedTabs page = + let + maybeCred = + Session.cred session + + decoder = + Feed.decoder maybeCred articlesPerPage + + params = + PaginatedList.params { page = page, resultsPerPage = articlesPerPage } + + request = + case feedTabs of + YourFeed cred -> + Api.get (Endpoint.feed params) maybeCred decoder + + GlobalFeed -> + Api.get (Endpoint.articles params) maybeCred decoder + + TagFeed tag -> + let + firstParam = + Url.Builder.string "tag" (Tag.toString tag) + in + Api.get (Endpoint.articles (firstParam :: params)) maybeCred decoder + in + Http.toTask request + |> Task.map (Feed.init session) + + +articlesPerPage : Int +articlesPerPage = + 10 + + +scrollToTop : Task x () +scrollToTop = + Dom.setViewport 0 0 + -- It's not worth showing the user anything special if scrolling fails. + -- If anything, we'd log this to an error recording service. + |> Task.onError (\_ -> Task.succeed ()) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session diff --git a/test/cases/elm-spa-page-login.elm b/test/cases/elm-spa-page-login.elm new file mode 100644 index 0000000..31bab51 --- /dev/null +++ b/test/cases/elm-spa-page-login.elm @@ -0,0 +1,315 @@ +module Page.Login exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| The login page. +-} + +import Api exposing (Cred) +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) + + + +-- MODEL + + +type alias Model = + { session : Session + , problems : List Problem + , form : Form + } + + +{-| Recording validation problems on a per-field basis facilitates displaying +them inline next to the field where the error occurred. + +I implemented it this way out of habit, then realized the spec called for +displaying all the errors at the top. I thought about simplifying it, but then +figured it'd be useful to show how I would normally model this data - assuming +the intended UX was to render errors per field. + +(The other part of this is having a view function like this: + +viewFieldErrors : ValidatedField -> List Problem -> Html msg + +...and it filters the list of problems to render only InvalidEntry ones for the +given ValidatedField. That way you can call this: + +viewFieldErrors Email problems + +...next to the `email` field, and call `viewFieldErrors Password problems` +next to the `password` field, and so on. + +The `LoginError` should be displayed elsewhere, since it doesn't correspond to +a particular field. + +-} +type Problem + = InvalidEntry ValidatedField String + | ServerError String + + +type alias Form = + { email : String + , password : String + } + + +init : Session -> ( Model, Cmd msg ) +init session = + ( { session = session + , problems = [] + , form = + { email = "" + , password = "" + } + } + , Cmd.none + ) + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + { title = "Login" + , 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 in" ] + , p [ class "text-xs-center" ] + [ a [ Route.href Route.Register ] + [ text "Need an account?" ] + ] + , ul [ class "error-messages" ] + (List.map viewProblem model.problems) + , viewForm model.form + ] + ] + ] + ] + } + + +viewProblem : Problem -> Html msg +viewProblem problem = + let + errorMessage = + case problem of + InvalidEntry _ str -> + str + + ServerError str -> + str + in + li [] [ text errorMessage ] + + +viewForm : Form -> Html Msg +viewForm form = + Html.form [ onSubmit SubmittedForm ] + [ 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 in" ] + ] + + + +-- UPDATE + + +type Msg + = SubmittedForm + | EnteredEmail String + | EnteredPassword String + | CompletedLogin (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 CompletedLogin (login validForm) + ) + + Err problems -> + ( { model | problems = problems } + , Cmd.none + ) + + EnteredEmail email -> + updateForm (\form -> { form | email = email }) model + + EnteredPassword password -> + updateForm (\form -> { form | password = password }) model + + CompletedLogin (Err error) -> + let + serverErrors = + Api.decodeErrors error + |> List.map ServerError + in + ( { model | problems = List.append model.problems serverErrors } + , Cmd.none + ) + + CompletedLogin (Ok viewer) -> + ( model + , Viewer.store viewer + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none. +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) + + + +-- 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 + = Email + | Password + + +fieldsToValidate : List ValidatedField +fieldsToValidate = + [ 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 + 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 + [] + + +{-| Don't trim while the user is typing! That would be super annoying. +Instead, trim only on submit. +-} +trimFields : Form -> TrimmedForm +trimFields form = + Trimmed + { email = String.trim form.email + , password = String.trim form.password + } + + + +-- HTTP + + +login : TrimmedForm -> Http.Request Viewer +login (Trimmed form) = + let + user = + Encode.object + [ ( "email", Encode.string form.email ) + , ( "password", Encode.string form.password ) + ] + + body = + Encode.object [ ( "user", user ) ] + |> Http.jsonBody + in + Api.login body Viewer.decoder + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session diff --git a/test/cases/elm-spa-page-notfound.elm b/test/cases/elm-spa-page-notfound.elm new file mode 100644 index 0000000..e0c534b --- /dev/null +++ b/test/cases/elm-spa-page-notfound.elm @@ -0,0 +1,21 @@ +module Page.NotFound exposing (view) + +import Asset +import Html exposing (Html, div, h1, img, main_, text) +import Html.Attributes exposing (alt, class, id, src, tabindex) + + + +-- VIEW + + +view : { title : String, content : Html msg } +view = + { title = "Page Not Found" + , content = + main_ [ id "content", class "container", tabindex -1 ] + [ h1 [] [ text "Not Found" ] + , div [ class "row" ] + [ img [ Asset.src Asset.error ] [] ] + ] + } diff --git a/test/cases/elm-spa-page-profile.elm b/test/cases/elm-spa-page-profile.elm new file mode 100644 index 0000000..906b527 --- /dev/null +++ b/test/cases/elm-spa-page-profile.elm @@ -0,0 +1,438 @@ +module Page.Profile exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| An Author's profile. +-} + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Article exposing (Article, Preview) +import Article.Feed as Feed +import Author exposing (Author(..), FollowedAuthor, UnfollowedAuthor) +import Avatar exposing (Avatar) +import Html exposing (..) +import Html.Attributes exposing (..) +import Http +import Loading +import Log +import Page +import PaginatedList exposing (PaginatedList) +import Profile exposing (Profile) +import Route +import Session exposing (Session) +import Task exposing (Task) +import Time +import Url.Builder +import Username exposing (Username) +import Viewer exposing (Viewer) + + + +-- MODEL + + +type alias Model = + { session : Session + , timeZone : Time.Zone + , errors : List String + , feedTab : FeedTab + , feedPage : Int + + -- Loaded independently from server + , author : Status Author + , feed : Status Feed.Model + } + + +type FeedTab + = MyArticles + | FavoritedArticles + + +type Status a + = Loading Username + | LoadingSlowly Username + | Loaded a + | Failed Username + + +init : Session -> Username -> ( Model, Cmd Msg ) +init session username = + let + maybeCred = + Session.cred session + in + ( { session = session + , timeZone = Time.utc + , errors = [] + , feedTab = defaultFeedTab + , feedPage = 1 + , author = Loading username + , feed = Loading username + } + , Cmd.batch + [ Author.fetch username maybeCred + |> Http.toTask + |> Task.mapError (Tuple.pair username) + |> Task.attempt CompletedAuthorLoad + , fetchFeed session defaultFeedTab username 1 + , Task.perform GotTimeZone Time.here + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + +currentUsername : Model -> Username +currentUsername model = + case model.author of + Loading username -> + username + + LoadingSlowly username -> + username + + Loaded author -> + Author.username author + + Failed username -> + username + + +defaultFeedTab : FeedTab +defaultFeedTab = + MyArticles + + + +-- HTTP + + +fetchFeed : Session -> FeedTab -> Username -> Int -> Cmd Msg +fetchFeed session feedTabs username page = + let + maybeCred = + Session.cred session + + firstParam = + case feedTabs of + MyArticles -> + Url.Builder.string "author" (Username.toString username) + + FavoritedArticles -> + Url.Builder.string "favorited" (Username.toString username) + + params = + firstParam :: PaginatedList.params { page = page, resultsPerPage = articlesPerPage } + + expect = + Feed.decoder maybeCred articlesPerPage + in + Api.get (Endpoint.articles params) maybeCred expect + |> Http.toTask + |> Task.map (Feed.init session) + |> Task.mapError (Tuple.pair username) + |> Task.attempt CompletedFeedLoad + + +articlesPerPage : Int +articlesPerPage = + 5 + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + let + title = + case model.author of + Loaded (IsViewer _ _) -> + myProfileTitle + + Loaded ((IsFollowing followedAuthor) as author) -> + titleForOther (Author.username author) + + Loaded ((IsNotFollowing unfollowedAuthor) as author) -> + titleForOther (Author.username author) + + Loading username -> + titleForMe (Session.cred model.session) username + + LoadingSlowly username -> + titleForMe (Session.cred model.session) username + + Failed username -> + titleForMe (Session.cred model.session) username + in + { title = title + , content = + case model.author of + Loaded author -> + let + profile = + Author.profile author + + username = + Author.username author + + followButton = + case Session.cred model.session of + Just cred -> + case author of + IsViewer _ _ -> + -- We can't follow ourselves! + text "" + + IsFollowing followedAuthor -> + Author.unfollowButton ClickedUnfollow cred followedAuthor + + IsNotFollowing unfollowedAuthor -> + Author.followButton ClickedFollow cred unfollowedAuthor + + Nothing -> + -- We can't follow if we're logged out + text "" + in + div [ class "profile-page" ] + [ Page.viewErrors ClickedDismissErrors model.errors + , div [ class "user-info" ] + [ div [ class "container" ] + [ div [ class "row" ] + [ div [ class "col-xs-12 col-md-10 offset-md-1" ] + [ img [ class "user-img", Avatar.src (Profile.avatar profile) ] [] + , h4 [] [ Username.toHtml username ] + , p [] [ text (Maybe.withDefault "" (Profile.bio profile)) ] + , followButton + ] + ] + ] + ] + , case model.feed of + Loaded feed -> + div [ class "container" ] + [ div [ class "row" ] + [ div [ class "col-xs-12 col-md-10 offset-md-1" ] + [ div [ class "articles-toggle" ] <| + List.concat + [ [ viewTabs model.feedTab ] + , Feed.viewArticles model.timeZone feed + |> List.map (Html.map GotFeedMsg) + , [ Feed.viewPagination ClickedFeedPage model.feedPage feed ] + ] + ] + ] + ] + + Loading _ -> + text "" + + LoadingSlowly _ -> + Loading.icon + + Failed _ -> + Loading.error "feed" + ] + + Loading _ -> + text "" + + LoadingSlowly _ -> + Loading.icon + + Failed _ -> + Loading.error "profile" + } + + + +-- PAGE TITLE + + +titleForOther : Username -> String +titleForOther otherUsername = + "Profile — " ++ Username.toString otherUsername + + +titleForMe : Maybe Cred -> Username -> String +titleForMe maybeCred username = + case maybeCred of + Just cred -> + if username == Api.username cred then + myProfileTitle + + else + defaultTitle + + Nothing -> + defaultTitle + + +myProfileTitle : String +myProfileTitle = + "My Profile" + + +defaultTitle : String +defaultTitle = + "Profile" + + + +-- TABS + + +viewTabs : FeedTab -> Html Msg +viewTabs tab = + case tab of + MyArticles -> + Feed.viewTabs [] myArticles [ favoritedArticles ] + + FavoritedArticles -> + Feed.viewTabs [ myArticles ] favoritedArticles [] + + +myArticles : ( String, Msg ) +myArticles = + ( "My Articles", ClickedTab MyArticles ) + + +favoritedArticles : ( String, Msg ) +favoritedArticles = + ( "Favorited Articles", ClickedTab FavoritedArticles ) + + + +-- UPDATE + + +type Msg + = ClickedDismissErrors + | ClickedFollow Cred UnfollowedAuthor + | ClickedUnfollow Cred FollowedAuthor + | ClickedTab FeedTab + | ClickedFeedPage Int + | CompletedFollowChange (Result Http.Error Author) + | CompletedAuthorLoad (Result ( Username, Http.Error ) Author) + | CompletedFeedLoad (Result ( Username, Http.Error ) Feed.Model) + | GotTimeZone Time.Zone + | GotFeedMsg Feed.Msg + | GotSession Session + | PassedSlowLoadThreshold + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ClickedDismissErrors -> + ( { model | errors = [] }, Cmd.none ) + + ClickedUnfollow cred followedAuthor -> + ( model + , Author.requestUnfollow followedAuthor cred + |> Http.send CompletedFollowChange + ) + + ClickedFollow cred unfollowedAuthor -> + ( model + , Author.requestFollow unfollowedAuthor cred + |> Http.send CompletedFollowChange + ) + + ClickedTab tab -> + ( { model | feedTab = tab } + , fetchFeed model.session tab (currentUsername model) 1 + ) + + ClickedFeedPage page -> + ( { model | feedPage = page } + , fetchFeed model.session model.feedTab (currentUsername model) page + ) + + CompletedFollowChange (Ok newAuthor) -> + ( { model | author = Loaded newAuthor } + , Cmd.none + ) + + CompletedFollowChange (Err error) -> + ( model + , Log.error + ) + + CompletedAuthorLoad (Ok author) -> + ( { model | author = Loaded author }, Cmd.none ) + + CompletedAuthorLoad (Err ( username, err )) -> + ( { model | author = Failed username } + , Log.error + ) + + CompletedFeedLoad (Ok feed) -> + ( { model | feed = Loaded feed } + , Cmd.none + ) + + CompletedFeedLoad (Err ( username, err )) -> + ( { model | feed = Failed username } + , Log.error + ) + + GotFeedMsg subMsg -> + case model.feed of + Loaded feed -> + let + ( newFeed, subCmd ) = + Feed.update (Session.cred model.session) subMsg feed + in + ( { model | feed = Loaded newFeed } + , Cmd.map GotFeedMsg subCmd + ) + + Loading _ -> + ( model, Log.error ) + + LoadingSlowly _ -> + ( model, Log.error ) + + Failed _ -> + ( model, Log.error ) + + GotTimeZone tz -> + ( { model | timeZone = tz }, Cmd.none ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + PassedSlowLoadThreshold -> + let + -- If any data is still Loading, change it to LoadingSlowly + -- so `view` knows to render a spinner. + feed = + case model.feed of + Loading username -> + LoadingSlowly username + + other -> + other + in + ( { model | feed = feed }, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session diff --git a/test/cases/elm-spa-page-register.elm b/test/cases/elm-spa-page-register.elm new file mode 100644 index 0000000..f1078e9 --- /dev/null +++ b/test/cases/elm-spa-page-register.elm @@ -0,0 +1,317 @@ +module Page.Register exposing (Model, Msg, init, subscriptions, toSession, update, view) + +import Api exposing (Cred) +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) + + + +-- 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 + , Viewer.store viewer + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none. +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 + Api.register body Viewer.decoder diff --git a/test/cases/elm-spa-page-settings.elm b/test/cases/elm-spa-page-settings.elm new file mode 100644 index 0000000..dc188a9 --- /dev/null +++ b/test/cases/elm-spa-page-settings.elm @@ -0,0 +1,461 @@ +module Page.Settings exposing (Model, Msg, init, subscriptions, toSession, update, view) + +import Api exposing (Cred) +import Api.Endpoint as Endpoint +import Avatar +import Browser.Navigation as Nav +import Email exposing (Email) +import Html exposing (Html, button, div, fieldset, h1, input, li, text, textarea, ul) +import Html.Attributes exposing (attribute, class, placeholder, type_, value) +import Html.Events exposing (onInput, onSubmit) +import Http +import Json.Decode as Decode exposing (Decoder, decodeString, field, list, string) +import Json.Decode.Pipeline exposing (hardcoded, required) +import Json.Encode as Encode +import Loading +import Log +import Profile exposing (Profile) +import Route +import Session exposing (Session) +import Task +import Username as Username exposing (Username) +import Viewer exposing (Viewer) + + + +-- MODEL + + +type alias Model = + { session : Session + , problems : List Problem + , status : Status + } + + +type alias Form = + { avatar : String + , bio : String + , email : String + , username : String + , password : String + } + + +type Status + = Loading + | LoadingSlowly + | Loaded Form + | Failed + + +type Problem + = InvalidEntry ValidatedField String + | ServerError String + + +init : Session -> ( Model, Cmd Msg ) +init session = + ( { session = session + , problems = [] + , status = Loading + } + , Cmd.batch + [ Api.get Endpoint.user (Session.cred session) (Decode.field "user" formDecoder) + |> Http.send CompletedFormLoad + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + +formDecoder : Decoder Form +formDecoder = + Decode.succeed Form + |> required "image" (Decode.map (Maybe.withDefault "") (Decode.nullable Decode.string)) + |> required "bio" (Decode.map (Maybe.withDefault "") (Decode.nullable Decode.string)) + |> required "email" Decode.string + |> required "username" Decode.string + |> hardcoded "" + + +{-| A form that has been validated. Only the `edit` function uses this. Its +purpose is to prevent us from forgetting to validate the form before passing +it to `edit`. + +This doesn't create any guarantees that the form was actually validated. If +we wanted to do that, we'd need to move the form data into a separate module! + +-} +type ValidForm + = Valid Form + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + { title = "Settings" + , content = + case Session.cred model.session of + Just cred -> + div [ class "settings-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 "Your Settings" ] + , ul [ class "error-messages" ] + (List.map viewProblem model.problems) + , case model.status of + Loaded form -> + viewForm cred form + + Loading -> + text "" + + LoadingSlowly -> + Loading.icon + + Failed -> + text "Error loading page." + ] + ] + ] + ] + + Nothing -> + text "Sign in to view your settings." + } + + +viewForm : Cred -> Form -> Html Msg +viewForm cred form = + Html.form [ onSubmit (SubmittedForm cred form) ] + [ fieldset [] + [ fieldset [ class "form-group" ] + [ input + [ class "form-control" + , placeholder "URL of profile picture" + , value form.avatar + , onInput EnteredAvatar + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , placeholder "Username" + , value form.username + , onInput EnteredUsername + ] + [] + ] + , fieldset [ class "form-group" ] + [ textarea + [ class "form-control form-control-lg" + , placeholder "Short bio about you" + , attribute "rows" "8" + , value form.bio + , onInput EnteredBio + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , placeholder "Email" + , value form.email + , onInput EnteredEmail + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , type_ "password" + , placeholder "Password" + , value form.password + , onInput EnteredPassword + ] + [] + ] + , button + [ class "btn btn-lg btn-primary pull-xs-right" ] + [ text "Update Settings" ] + ] + ] + + +viewProblem : Problem -> Html msg +viewProblem problem = + let + errorMessage = + case problem of + InvalidEntry _ message -> + message + + ServerError message -> + message + in + li [] [ text errorMessage ] + + + +-- UPDATE + + +type Msg + = SubmittedForm Cred Form + | EnteredEmail String + | EnteredUsername String + | EnteredPassword String + | EnteredBio String + | EnteredAvatar String + | CompletedFormLoad (Result Http.Error Form) + | CompletedSave (Result Http.Error Viewer) + | GotSession Session + | PassedSlowLoadThreshold + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + CompletedFormLoad (Ok form) -> + ( { model | status = Loaded form } + , Cmd.none + ) + + CompletedFormLoad (Err _) -> + ( { model | status = Failed } + , Cmd.none + ) + + SubmittedForm cred form -> + case validate form of + Ok validForm -> + ( { model | status = Loaded form } + , edit cred validForm + |> Http.send CompletedSave + ) + + Err problems -> + ( { model | problems = problems } + , Cmd.none + ) + + EnteredEmail email -> + updateForm (\form -> { form | email = email }) model + + EnteredUsername username -> + updateForm (\form -> { form | username = username }) model + + EnteredPassword password -> + updateForm (\form -> { form | password = password }) model + + EnteredBio bio -> + updateForm (\form -> { form | bio = bio }) model + + EnteredAvatar avatar -> + updateForm (\form -> { form | avatar = avatar }) model + + CompletedSave (Err error) -> + let + serverErrors = + Api.decodeErrors error + |> List.map ServerError + in + ( { model | problems = List.append model.problems serverErrors } + , Cmd.none + ) + + CompletedSave (Ok viewer) -> + ( model + , Viewer.store viewer + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + PassedSlowLoadThreshold -> + case model.status of + Loading -> + ( { model | status = LoadingSlowly } + , Cmd.none + ) + + _ -> + ( model, Cmd.none ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none. +Useful for recording form fields! +-} +updateForm : (Form -> Form) -> Model -> ( Model, Cmd msg ) +updateForm transform model = + case model.status of + Loaded form -> + ( { model | status = Loaded (transform form) }, Cmd.none ) + + _ -> + ( model, Log.error ) + + + +-- 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! + +NOTE: there are no ImageUrl or Bio variants here, because they aren't validated! + +-} +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 -> + let + passwordLength = + String.length form.password + in + if passwordLength > 0 && passwordLength < 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 + { avatar = String.trim form.avatar + , bio = String.trim form.bio + , email = String.trim form.email + , username = String.trim form.username + , password = String.trim form.password + } + + + +-- HTTP + + +{-| This takes a Valid Form as a reminder that it needs to have been validated +first. +-} +edit : Cred -> TrimmedForm -> Http.Request Viewer +edit cred (Trimmed form) = + let + encodedAvatar = + case form.avatar of + "" -> + Encode.null + + avatar -> + Encode.string avatar + + updates = + [ ( "username", Encode.string form.username ) + , ( "email", Encode.string form.email ) + , ( "bio", Encode.string form.bio ) + , ( "image", encodedAvatar ) + ] + + encodedUser = + Encode.object <| + case form.password of + "" -> + updates + + password -> + ( "password", Encode.string password ) :: updates + + body = + Encode.object [ ( "user", encodedUser ) ] + |> Http.jsonBody + in + Api.settings cred body Viewer.decoder + + +nothingIfEmpty : String -> Maybe String +nothingIfEmpty str = + if String.isEmpty str then + Nothing + + else + Just str diff --git a/test/cases/elm-spa-page.elm b/test/cases/elm-spa-page.elm new file mode 100644 index 0000000..f1790bf --- /dev/null +++ b/test/cases/elm-spa-page.elm @@ -0,0 +1,156 @@ +module Page exposing (Page(..), view, viewErrors) + +import Api exposing (Cred) +import Avatar +import Browser exposing (Document) +import Html exposing (Html, a, button, div, footer, i, img, li, nav, p, span, text, ul) +import Html.Attributes exposing (class, classList, href, style) +import Html.Events exposing (onClick) +import Profile +import Route exposing (Route) +import Session exposing (Session) +import Username exposing (Username) +import Viewer exposing (Viewer) + + +{-| Determines which navbar link (if any) will be rendered as active. + +Note that we don't enumerate every page here, because the navbar doesn't +have links for every page. Anything that's not part of the navbar falls +under Other. + +-} +type Page + = Other + | Home + | Login + | Register + | Settings + | Profile Username + | NewArticle + + +{-| Take a page's Html and frames it with a header and footer. + +The caller provides the current user, so we can display in either +"signed in" (rendering username) or "signed out" mode. + +isLoading is for determining whether we should show a loading spinner +in the header. (This comes up during slow page transitions.) + +-} +view : Maybe Viewer -> Page -> { title : String, content : Html msg } -> Document msg +view maybeViewer page { title, content } = + { title = title ++ " - Conduit" + , body = viewHeader page maybeViewer :: content :: [ viewFooter ] + } + + +viewHeader : Page -> Maybe Viewer -> Html msg +viewHeader page maybeViewer = + nav [ class "navbar navbar-light" ] + [ div [ class "container" ] + [ a [ class "navbar-brand", Route.href Route.Home ] + [ text "conduit" ] + , ul [ class "nav navbar-nav pull-xs-right" ] <| + navbarLink page Route.Home [ text "Home" ] + :: viewMenu page maybeViewer + ] + ] + + +viewMenu : Page -> Maybe Viewer -> List (Html msg) +viewMenu page maybeViewer = + let + linkTo = + navbarLink page + in + case maybeViewer of + Just viewer -> + let + username = + Viewer.username viewer + + avatar = + Viewer.avatar viewer + in + [ linkTo Route.NewArticle [ i [ class "ion-compose" ] [], text "\u{00A0}New Post" ] + , linkTo Route.Settings [ i [ class "ion-gear-a" ] [], text "\u{00A0}Settings" ] + , linkTo + (Route.Profile username) + [ img [ class "user-pic", Avatar.src avatar ] [] + , Username.toHtml username + ] + , linkTo Route.Logout [ text "Sign out" ] + ] + + Nothing -> + [ linkTo Route.Login [ text "Sign in" ] + , linkTo Route.Register [ text "Sign up" ] + ] + + +viewFooter : Html msg +viewFooter = + footer [] + [ div [ class "container" ] + [ a [ class "logo-font", href "/" ] [ text "conduit" ] + , span [ class "attribution" ] + [ text "An interactive learning project from " + , a [ href "https://thinkster.io" ] [ text "Thinkster" ] + , text ". Code & design licensed under MIT." + ] + ] + ] + + +navbarLink : Page -> Route -> List (Html msg) -> Html msg +navbarLink page route linkContent = + li [ classList [ ( "nav-item", True ), ( "active", isActive page route ) ] ] + [ a [ class "nav-link", Route.href route ] linkContent ] + + +isActive : Page -> Route -> Bool +isActive page route = + case ( page, route ) of + ( Home, Route.Home ) -> + True + + ( Login, Route.Login ) -> + True + + ( Register, Route.Register ) -> + True + + ( Settings, Route.Settings ) -> + True + + ( Profile pageUsername, Route.Profile routeUsername ) -> + pageUsername == routeUsername + + ( NewArticle, Route.NewArticle ) -> + True + + _ -> + False + + +{-| Render dismissable errors. We use this all over the place! +-} +viewErrors : msg -> List String -> Html msg +viewErrors dismissErrors errors = + if List.isEmpty errors then + Html.text "" + + else + div + [ class "error-messages" + , style "position" "fixed" + , style "top" "0" + , style "background" "rgb(250, 250, 250)" + , style "padding" "20px" + , style "border" "1px solid" + ] + <| + List.map (\error -> p [] [ text error ]) errors + ++ [ button [ onClick dismissErrors ] [ text "Ok" ] ] diff --git a/test/cases/elm-spa-paginatedlist.elm b/test/cases/elm-spa-paginatedlist.elm new file mode 100644 index 0000000..55512c5 --- /dev/null +++ b/test/cases/elm-spa-paginatedlist.elm @@ -0,0 +1,70 @@ +module PaginatedList exposing (PaginatedList, fromList, map, params, total, values) + +import Html exposing (Html, a, li, text, ul) +import Html.Attributes exposing (class, classList, href) +import Html.Events exposing (onClick) +import Json.Decode as Decode exposing (Decoder) +import Task exposing (Task) +import Url.Builder exposing (QueryParameter) + + + +-- TYPES + + +type PaginatedList a + = PaginatedList + { values : List a + , total : Int + } + + + +-- INFO + + +values : PaginatedList a -> List a +values (PaginatedList info) = + info.values + + +total : PaginatedList a -> Int +total (PaginatedList info) = + info.total + + + +-- CREATE + + +fromList : Int -> List a -> PaginatedList a +fromList totalCount list = + PaginatedList { values = list, total = totalCount } + + + +-- TRANSFORM + + +map : (a -> a) -> PaginatedList a -> PaginatedList a +map transform (PaginatedList info) = + PaginatedList { info | values = List.map transform info.values } + + + +-- PARAMS + + +{-| I decided to accept a record here so I don't mess up the argument order of the two Ints. +-} +params : + { page : Int, resultsPerPage : Int } + -> List QueryParameter +params { page, resultsPerPage } = + let + offset = + (page - 1) * resultsPerPage + in + [ Url.Builder.string "limit" (String.fromInt resultsPerPage) + , Url.Builder.string "offset" (String.fromInt offset) + ] diff --git a/test/cases/elm-spa-profile.elm b/test/cases/elm-spa-profile.elm new file mode 100644 index 0000000..536582a --- /dev/null +++ b/test/cases/elm-spa-profile.elm @@ -0,0 +1,54 @@ +module Profile exposing (Profile, avatar, bio, decoder) + +{-| A user's profile - potentially your own! + +Contrast with Cred, which is the currently signed-in user. + +-} + +import Api exposing (Cred) +import Avatar exposing (Avatar) +import Http +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (required) +import Username exposing (Username) + + + +-- TYPES + + +type Profile + = Profile Internals + + +type alias Internals = + { bio : Maybe String + , avatar : Avatar + } + + + +-- INFO + + +bio : Profile -> Maybe String +bio (Profile info) = + info.bio + + +avatar : Profile -> Avatar +avatar (Profile info) = + info.avatar + + + +-- SERIALIZATION + + +decoder : Decoder Profile +decoder = + Decode.succeed Internals + |> required "bio" (Decode.nullable Decode.string) + |> required "image" Avatar.decoder + |> Decode.map Profile diff --git a/test/cases/elm-spa-route.elm b/test/cases/elm-spa-route.elm new file mode 100644 index 0000000..03568fb --- /dev/null +++ b/test/cases/elm-spa-route.elm @@ -0,0 +1,108 @@ +module Route exposing (Route(..), fromUrl, href, replaceUrl) + +import Article.Slug as Slug exposing (Slug) +import Browser.Navigation as Nav +import Html exposing (Attribute) +import Html.Attributes as Attr +import Profile exposing (Profile) +import Url exposing (Url) +import Url.Parser as Parser exposing ((), Parser, oneOf, s, string) +import Username exposing (Username) + + + +-- ROUTING + + +type Route + = Home + | Root + | Login + | Logout + | Register + | Settings + | Article Slug + | Profile Username + | NewArticle + | EditArticle Slug + + +parser : Parser (Route -> a) a +parser = + oneOf + [ Parser.map Home Parser.top + , Parser.map Login (s "login") + , Parser.map Logout (s "logout") + , Parser.map Settings (s "settings") + , Parser.map Profile (s "profile" Username.urlParser) + , Parser.map Register (s "register") + , Parser.map Article (s "article" Slug.urlParser) + , Parser.map NewArticle (s "editor") + , Parser.map EditArticle (s "editor" Slug.urlParser) + ] + + + +-- PUBLIC HELPERS + + +href : Route -> Attribute msg +href targetRoute = + Attr.href (routeToString targetRoute) + + +replaceUrl : Nav.Key -> Route -> Cmd msg +replaceUrl key route = + Nav.replaceUrl key (routeToString route) + + +fromUrl : Url -> Maybe Route +fromUrl url = + -- The RealWorld spec treats the fragment like a path. + -- This makes it *literally* the path, so we can proceed + -- with parsing as if it had been a normal path all along. + { url | path = Maybe.withDefault "" url.fragment, fragment = Nothing } + |> Parser.parse parser + + + +-- INTERNAL + + +routeToString : Route -> String +routeToString page = + "#/" ++ String.join "/" (routeToPieces page) + + +routeToPieces : Route -> List String +routeToPieces page = + case page of + Home -> + [] + + Root -> + [] + + Login -> + [ "login" ] + + Logout -> + [ "logout" ] + + Register -> + [ "register" ] + + Settings -> + [ "settings" ] + + Article slug -> + [ "article", Slug.toString slug ] + + Profile username -> + [ "profile", Username.toString username ] + + NewArticle -> + [ "editor" ] + + EditArticle slug -> + [ "editor", Slug.toString slug ] diff --git a/test/cases/elm-spa-session.elm b/test/cases/elm-spa-session.elm new file mode 100644 index 0000000..8b5436e --- /dev/null +++ b/test/cases/elm-spa-session.elm @@ -0,0 +1,76 @@ +module Session exposing (Session, changes, cred, fromViewer, navKey, viewer) + +import Api exposing (Cred) +import Avatar exposing (Avatar) +import Browser.Navigation as Nav +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (custom, required) +import Json.Encode as Encode exposing (Value) +import Profile exposing (Profile) +import Time +import Viewer exposing (Viewer) + + + +-- TYPES + + +type Session + = LoggedIn Nav.Key Viewer + | Guest Nav.Key + + + +-- INFO + + +viewer : Session -> Maybe Viewer +viewer session = + case session of + LoggedIn _ val -> + Just val + + Guest _ -> + Nothing + + +cred : Session -> Maybe Cred +cred session = + case session of + LoggedIn _ val -> + Just (Viewer.cred val) + + Guest _ -> + Nothing + + +navKey : Session -> Nav.Key +navKey session = + case session of + LoggedIn key _ -> + key + + Guest key -> + key + + + +-- CHANGES + + +changes : (Session -> msg) -> Nav.Key -> Sub msg +changes toMsg key = + Api.viewerChanges (\maybeViewer -> toMsg (fromViewer key maybeViewer)) Viewer.decoder + + +fromViewer : Nav.Key -> Maybe Viewer -> Session +fromViewer key maybeViewer = + -- It's stored in localStorage as a JSON String; + -- first decode the Value as a String, then + -- decode that String as JSON. + case maybeViewer of + Just viewerVal -> + LoggedIn key viewerVal + + Nothing -> + Guest key diff --git a/test/cases/elm-spa-timestamp.elm b/test/cases/elm-spa-timestamp.elm new file mode 100644 index 0000000..07982d6 --- /dev/null +++ b/test/cases/elm-spa-timestamp.elm @@ -0,0 +1,77 @@ +module Timestamp exposing (format, view) + +import Html exposing (Html, span, text) +import Html.Attributes exposing (class) +import Json.Decode as Decode exposing (Decoder, fail, succeed) +import Time exposing (Month(..)) + + + +-- VIEW + + +view : Time.Zone -> Time.Posix -> Html msg +view timeZone timestamp = + span [ class "date" ] [ text (format timeZone timestamp) ] + + + +-- FORMAT + + +{-| Format a timestamp as a String, like so: + + "February 14, 2018" + +For more complex date formatting scenarios, here's a nice package: + + +-} +format : Time.Zone -> Time.Posix -> String +format zone time = + let + month = + case Time.toMonth zone time of + Jan -> + "January" + + Feb -> + "February" + + Mar -> + "March" + + Apr -> + "April" + + May -> + "May" + + Jun -> + "June" + + Jul -> + "July" + + Aug -> + "August" + + Sep -> + "September" + + Oct -> + "October" + + Nov -> + "November" + + Dec -> + "December" + + day = + String.fromInt (Time.toDay zone time) + + year = + String.fromInt (Time.toYear zone time) + in + month ++ " " ++ day ++ ", " ++ year diff --git a/test/cases/elm-spa-username.elm b/test/cases/elm-spa-username.elm new file mode 100644 index 0000000..a7f17ec --- /dev/null +++ b/test/cases/elm-spa-username.elm @@ -0,0 +1,47 @@ +module Username exposing (Username, decoder, encode, toHtml, toString, urlParser) + +import Html exposing (Html) +import Json.Decode as Decode exposing (Decoder) +import Json.Encode as Encode exposing (Value) +import Url.Parser + + + +-- TYPES + + +type Username + = Username String + + + +-- CREATE + + +decoder : Decoder Username +decoder = + Decode.map Username Decode.string + + + +-- TRANSFORM + + +encode : Username -> Value +encode (Username username) = + Encode.string username + + +toString : Username -> String +toString (Username username) = + username + + +urlParser : Url.Parser.Parser (Username -> a) a +urlParser = + Url.Parser.custom "USERNAME" (\str -> Just (Username str)) + + +toHtml : Username -> Html msg +toHtml (Username username) = + Html.text username diff --git a/test/cases/elm-spa-viewer.elm b/test/cases/elm-spa-viewer.elm new file mode 100644 index 0000000..58ec005 --- /dev/null +++ b/test/cases/elm-spa-viewer.elm @@ -0,0 +1,66 @@ +module Viewer exposing (Viewer, avatar, cred, decoder, minPasswordChars, store, username) + +{-| The logged-in user currently viewing this page. It stores enough data to +be able to render the menu bar (username and avatar), along with Cred so it's +impossible to have a Viewer if you aren't logged in. +-} + +import Api exposing (Cred) +import Avatar exposing (Avatar) +import Email exposing (Email) +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (custom, required) +import Json.Encode as Encode exposing (Value) +import Profile exposing (Profile) +import Username exposing (Username) + + + +-- TYPES + + +type Viewer + = Viewer Avatar Cred + + + +-- INFO + + +cred : Viewer -> Cred +cred (Viewer _ val) = + val + + +username : Viewer -> Username +username (Viewer _ val) = + Api.username val + + +avatar : Viewer -> Avatar +avatar (Viewer val _) = + val + + +{-| Passwords must be at least this many characters long! +-} +minPasswordChars : Int +minPasswordChars = + 6 + + + +-- SERIALIZATION + + +decoder : Decoder (Cred -> Viewer) +decoder = + Decode.succeed Viewer + |> custom (Decode.field "image" Avatar.decoder) + + +store : Viewer -> Cmd msg +store (Viewer avatarVal credVal) = + Api.storeCredWith + credVal + avatarVal