diff --git a/intro/part6/.gitignore b/intro/part6/.gitignore new file mode 100644 index 0000000..3ebe788 --- /dev/null +++ b/intro/part6/.gitignore @@ -0,0 +1,6 @@ +# elm-package generated files +elm-stuff/ +# elm-repl generated files +repl-temp-* + +elm.js diff --git a/intro/part6/.travis.yml b/intro/part6/.travis.yml new file mode 100644 index 0000000..ecd6830 --- /dev/null +++ b/intro/part6/.travis.yml @@ -0,0 +1,34 @@ +sudo: false + +cache: + directories: + - tests/elm-stuff/build-artifacts + - sysconfcpus + +before_install: + - echo -e "Host github.com\n\tStrictHostKeyChecking no\n" >> ~/.ssh/config + - | # epic build time improvement - see https://github.com/elm-lang/elm-compiler/issues/1473#issuecomment-245704142 + if [ ! -d sysconfcpus/bin ]; + then + git clone https://github.com/obmarg/libsysconfcpus.git; + cd libsysconfcpus; + ./configure --prefix=$TRAVIS_BUILD_DIR/sysconfcpus; + make && make install; + cd ..; + fi + + +install: + - npm install -g elm@0.18.0 elm-test elm-format@exp + - mv $(npm config get prefix)/bin/elm-make $(npm config get prefix)/bin/elm-make-old + - printf '%s\n\n' '#!/bin/bash' 'echo "Running elm-make with sysconfcpus -n 2"' '$TRAVIS_BUILD_DIR/sysconfcpus/bin/sysconfcpus -n 2 elm-make-old "$@"' > $(npm config get prefix)/bin/elm-make + - chmod +x $(npm config get prefix)/bin/elm-make + - travis_retry elm-package install --yes + - cd tests + - npm install + - travis_retry elm-package install --yes + - cd .. + +script: + - elm-format --validate src tests + - elm test diff --git a/intro/part6/README.md b/intro/part6/README.md new file mode 100644 index 0000000..0a67b83 --- /dev/null +++ b/intro/part6/README.md @@ -0,0 +1,18 @@ +# Part 6 + +Like last time, we'll be building `src/Main.elm`, but editing a different file. + +To build everything, `cd` into the `part6/` directory and run: + +```shell +elm make src/Main.elm --output ../server/public/elm.js +``` + +Then open `http://localhost:3000` in your browser. + +## Exercise + +There are two TODOs to resolve, in these files. + +1. `src/Avatar.elm` - go for this one first! +2. `src/Page/Article/Editor.elm` diff --git a/intro/part6/assets/icons/android-chrome-192x192.png b/intro/part6/assets/icons/android-chrome-192x192.png new file mode 100644 index 0000000..ff83974 Binary files /dev/null and b/intro/part6/assets/icons/android-chrome-192x192.png differ diff --git a/intro/part6/assets/icons/android-chrome-512x512.png b/intro/part6/assets/icons/android-chrome-512x512.png new file mode 100644 index 0000000..ec8f581 Binary files /dev/null and b/intro/part6/assets/icons/android-chrome-512x512.png differ diff --git a/intro/part6/assets/icons/apple-touch-icon.png b/intro/part6/assets/icons/apple-touch-icon.png new file mode 100644 index 0000000..0a048cc Binary files /dev/null and b/intro/part6/assets/icons/apple-touch-icon.png differ diff --git a/intro/part6/assets/icons/browserconfig.xml b/intro/part6/assets/icons/browserconfig.xml new file mode 100644 index 0000000..b3930d0 --- /dev/null +++ b/intro/part6/assets/icons/browserconfig.xml @@ -0,0 +1,9 @@ + + + + + + #da532c + + + diff --git a/intro/part6/assets/icons/favicon-16x16.png b/intro/part6/assets/icons/favicon-16x16.png new file mode 100644 index 0000000..246ebd7 Binary files /dev/null and b/intro/part6/assets/icons/favicon-16x16.png differ diff --git a/intro/part6/assets/icons/favicon-32x32.png b/intro/part6/assets/icons/favicon-32x32.png new file mode 100644 index 0000000..72a40d1 Binary files /dev/null and b/intro/part6/assets/icons/favicon-32x32.png differ diff --git a/intro/part6/assets/icons/favicon.ico b/intro/part6/assets/icons/favicon.ico new file mode 100644 index 0000000..ac27808 Binary files /dev/null and b/intro/part6/assets/icons/favicon.ico differ diff --git a/intro/part6/assets/icons/mstile-144x144.png b/intro/part6/assets/icons/mstile-144x144.png new file mode 100644 index 0000000..c606809 Binary files /dev/null and b/intro/part6/assets/icons/mstile-144x144.png differ diff --git a/intro/part6/assets/icons/mstile-150x150.png b/intro/part6/assets/icons/mstile-150x150.png new file mode 100644 index 0000000..df842e1 Binary files /dev/null and b/intro/part6/assets/icons/mstile-150x150.png differ diff --git a/intro/part6/assets/icons/mstile-310x150.png b/intro/part6/assets/icons/mstile-310x150.png new file mode 100644 index 0000000..e3f88b8 Binary files /dev/null and b/intro/part6/assets/icons/mstile-310x150.png differ diff --git a/intro/part6/assets/icons/mstile-310x310.png b/intro/part6/assets/icons/mstile-310x310.png new file mode 100644 index 0000000..f0702f4 Binary files /dev/null and b/intro/part6/assets/icons/mstile-310x310.png differ diff --git a/intro/part6/assets/icons/mstile-70x70.png b/intro/part6/assets/icons/mstile-70x70.png new file mode 100644 index 0000000..8b7596f Binary files /dev/null and b/intro/part6/assets/icons/mstile-70x70.png differ diff --git a/intro/part6/assets/icons/safari-pinned-tab.svg b/intro/part6/assets/icons/safari-pinned-tab.svg new file mode 100644 index 0000000..1d414ab --- /dev/null +++ b/intro/part6/assets/icons/safari-pinned-tab.svg @@ -0,0 +1,29 @@ + + + + +Created by potrace 1.11, written by Peter Selinger 2001-2013 + + + + + + + + + + + diff --git a/intro/part6/assets/images/error.jpg b/intro/part6/assets/images/error.jpg new file mode 100644 index 0000000..dfc53d1 Binary files /dev/null and b/intro/part6/assets/images/error.jpg differ diff --git a/intro/part6/assets/images/loading.svg b/intro/part6/assets/images/loading.svg new file mode 100644 index 0000000..4549525 --- /dev/null +++ b/intro/part6/assets/images/loading.svg @@ -0,0 +1,17 @@ + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/intro/part6/assets/site.webmanifest b/intro/part6/assets/site.webmanifest new file mode 100644 index 0000000..b20abb7 --- /dev/null +++ b/intro/part6/assets/site.webmanifest @@ -0,0 +1,19 @@ +{ + "name": "", + "short_name": "", + "icons": [ + { + "src": "/android-chrome-192x192.png", + "sizes": "192x192", + "type": "image/png" + }, + { + "src": "/android-chrome-512x512.png", + "sizes": "512x512", + "type": "image/png" + } + ], + "theme_color": "#ffffff", + "background_color": "#ffffff", + "display": "standalone" +} diff --git a/intro/part6/elm.json b/intro/part6/elm.json new file mode 100644 index 0000000..2dd3243 --- /dev/null +++ b/intro/part6/elm.json @@ -0,0 +1,35 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.0", + "dependencies": { + "direct": { + "NoRedInk/json-decode-pipeline": "1.0.0", + "elm/browser": "1.0.0", + "elm/core": "1.0.0", + "elm/html": "1.0.0", + "elm/http": "1.0.0", + "elm/json": "1.0.0", + "elm/time": "1.0.0", + "elm/url": "1.0.0", + "elm-explorations/markdown": "1.0.0", + "lukewestby/elm-http-builder": "6.0.0", + "rtfeldman/elm-iso8601": "1.0.1" + }, + "indirect": { + "elm/parser": "1.0.0", + "elm/regex": "1.0.0", + "elm/virtual-dom": "1.0.0" + } + }, + "test-dependencies": { + "direct": { + "elm-explorations/test": "1.0.0" + }, + "indirect": { + "elm/random": "1.0.0" + } + } +} diff --git a/intro/part6/index.html b/intro/part6/index.html new file mode 100644 index 0000000..7b6bea9 --- /dev/null +++ b/intro/part6/index.html @@ -0,0 +1,41 @@ + + + + + Conduit + + + + + + + + + + + + + + + + + + + + + diff --git a/intro/part6/src/Api.elm b/intro/part6/src/Api.elm new file mode 100644 index 0000000..bed2e13 --- /dev/null +++ b/intro/part6/src/Api.elm @@ -0,0 +1,53 @@ +module Api exposing (addServerError, decodeErrors, url) + +import Http +import Json.Decode as Decode exposing (Decoder, decodeString, field, string) +import Json.Decode.Pipeline as Pipeline exposing (optional) +import Url.Builder + + + +-- URL + + +{-| Get a URL to the Conduit API. +-} +url : List String -> String +url paths = + -- 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.relative ("api" :: paths) [] + + + +-- 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 diff --git a/intro/part6/src/Article.elm b/intro/part6/src/Article.elm new file mode 100644 index 0000000..b5c550a --- /dev/null +++ b/intro/part6/src/Article.elm @@ -0,0 +1,321 @@ +module Article + exposing + ( Article + , Full + , Preview + , author + , body + , favorite + , favoriteButton + , fetch + , fromPreview + , fullDecoder + , mapAuthor + , metadata + , previewDecoder + , slug + , unfavorite + , unfavoriteButton + , url + ) + +{-| 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 +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 HttpBuilder exposing (RequestBuilder, withBody, withExpect, withQueryParams) +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 Timestamp +import Username as Username exposing (Username) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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! +See commit c2640ae3abd60262cdaafe6adee3f41d84cd85c3 for how it looked before. +) + +-} +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" Timestamp.iso8601Decoder + |> required "favorited" Decode.bool + |> required "favoritesCount" Decode.int + + + +-- SINGLE + + +fetch : Maybe Cred -> Slug -> Http.Request (Article Full) +fetch maybeCred articleSlug = + let + expect = + fullDecoder maybeCred + |> Decode.field "article" + |> Http.expectJson + in + url articleSlug [] + |> HttpBuilder.get + |> HttpBuilder.withExpect expect + |> Cred.addHeaderIfAvailable maybeCred + |> HttpBuilder.toRequest + + + +-- FAVORITE + + +favorite : Slug -> Cred -> Http.Request (Article Preview) +favorite articleSlug cred = + buildFavorite HttpBuilder.post articleSlug cred + + +unfavorite : Slug -> Cred -> Http.Request (Article Preview) +unfavorite articleSlug cred = + buildFavorite HttpBuilder.delete articleSlug cred + + +buildFavorite : + (String -> RequestBuilder a) + -> Slug + -> Cred + -> Http.Request (Article Preview) +buildFavorite builderFromUrl articleSlug cred = + let + expect = + previewDecoder (Just cred) + |> Decode.field "article" + |> Http.expectJson + in + builderFromUrl (url articleSlug [ "favorite" ]) + |> Cred.addHeader cred + |> withExpect expect + |> HttpBuilder.toRequest + + +{-| 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 )) + + + +-- URLS + + +url : Slug -> List String -> String +url articleSlug paths = + allArticlesUrl (Slug.toString articleSlug :: paths) + + +allArticlesUrl : List String -> String +allArticlesUrl paths = + Api.url ("articles" :: paths) diff --git a/intro/part6/src/Article/Body.elm b/intro/part6/src/Article/Body.elm new file mode 100644 index 0000000..b1c55f1 --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Article/Comment.elm b/intro/part6/src/Article/Comment.elm new file mode 100644 index 0000000..5517a30 --- /dev/null +++ b/intro/part6/src/Article/Comment.elm @@ -0,0 +1,139 @@ +module Article.Comment + exposing + ( Comment + , author + , body + , createdAt + , delete + , id + , list + , post + ) + +import Api +import Article exposing (Article) +import Article.Slug as Slug exposing (Slug) +import Author exposing (Author) +import CommentId exposing (CommentId) +import Http +import HttpBuilder exposing (RequestBuilder, withExpect, withQueryParams) +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 Timestamp +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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 = + allCommentsUrl articleSlug [] + |> HttpBuilder.get + |> HttpBuilder.withExpect (Http.expectJson (Decode.field "comments" (Decode.list (decoder maybeCred)))) + |> Cred.addHeaderIfAvailable maybeCred + |> HttpBuilder.toRequest + + + +-- POST + + +post : Slug -> String -> Cred -> Http.Request Comment +post articleSlug commentBody cred = + allCommentsUrl articleSlug [] + |> HttpBuilder.post + |> HttpBuilder.withBody (Http.jsonBody (encodeCommentBody commentBody)) + |> HttpBuilder.withExpect (Http.expectJson (Decode.field "comment" (decoder (Just cred)))) + |> Cred.addHeader cred + |> HttpBuilder.toRequest + + +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 = + commentUrl articleSlug commentId + |> HttpBuilder.delete + |> Cred.addHeader cred + |> HttpBuilder.toRequest + + + +-- SERIALIZATION + + +decoder : Maybe Cred -> Decoder Comment +decoder maybeCred = + Decode.succeed Internals + |> required "id" CommentId.decoder + |> required "body" Decode.string + |> required "createdAt" Timestamp.iso8601Decoder + |> required "author" (Author.decoder maybeCred) + |> Decode.map Comment + + + +-- URLS + + +commentUrl : Slug -> CommentId -> String +commentUrl articleSlug commentId = + allCommentsUrl articleSlug [ CommentId.toString commentId ] + + +allCommentsUrl : Slug -> List String -> String +allCommentsUrl articleSlug paths = + Api.url ([ "articles", Slug.toString articleSlug, "comments" ] ++ paths) diff --git a/intro/part6/src/Article/Feed.elm b/intro/part6/src/Article/Feed.elm new file mode 100644 index 0000000..a5a482a --- /dev/null +++ b/intro/part6/src/Article/Feed.elm @@ -0,0 +1,421 @@ +module Article.Feed + exposing + ( Model + , Msg + , init + , selectTag + , update + , viewArticles + , viewFeedSources + ) + +import Api +import Article exposing (Article, Preview) +import Article.FeedSources as FeedSources exposing (FeedSources, Source(..)) +import Article.Slug as ArticleSlug exposing (Slug) +import Article.Tag as Tag exposing (Tag) +import Author +import Avatar exposing (Avatar) +import Browser.Dom as Dom +import Html exposing (..) +import Html.Attributes exposing (attribute, class, classList, href, id, placeholder, src) +import Html.Events exposing (onClick) +import Http +import HttpBuilder exposing (RequestBuilder, withExpect, withQueryParams) +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 Username exposing (Username) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + +{-| 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 InternalModel + + +{-| 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 InternalModel = + { session : Session + , errors : List String + , articles : PaginatedList (Article Preview) + , sources : FeedSources + , isLoading : Bool + } + + +init : Session -> FeedSources -> Task Http.Error Model +init session sources = + let + fromArticles articles = + Model + { session = session + , errors = [] + , articles = articles + , sources = sources + , isLoading = False + } + in + FeedSources.selected sources + |> fetch (Session.cred session) 1 + |> Task.map fromArticles + + + +-- VIEW + + +viewArticles : Time.Zone -> Model -> List (Html Msg) +viewArticles timeZone (Model { articles, sources, session }) = + let + maybeCred = + Session.cred session + + articlesHtml = + PaginatedList.values articles + |> List.map (viewPreview maybeCred timeZone) + + feedSource = + FeedSources.selected sources + + pagination = + PaginatedList.view ClickedFeedPage articles (limit feedSource) + in + List.append articlesHtml [ pagination ] + + +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..." ] + ] + ] + + +viewFeedSources : Model -> Html Msg +viewFeedSources (Model { sources, isLoading, errors }) = + let + errorsHtml = + Page.viewErrors ClickedDismissErrors errors + in + ul [ class "nav nav-pills outline-active" ] <| + List.concat + [ List.map (viewFeedSource False) (FeedSources.before sources) + , [ viewFeedSource True (FeedSources.selected sources) ] + , List.map (viewFeedSource False) (FeedSources.after sources) + , [ errorsHtml ] + ] + + +viewFeedSource : Bool -> Source -> Html Msg +viewFeedSource isSelected source = + li [ class "nav-item" ] + [ a + [ classList [ ( "nav-link", True ), ( "active", isSelected ) ] + , onClick (ClickedFeedSource source) + + -- The RealWorld CSS requires an href to work properly. + , href "" + ] + [ text (sourceName source) ] + ] + + +selectTag : Maybe Cred -> Tag -> Cmd Msg +selectTag maybeCred tag = + let + source = + TagFeed tag + in + fetch maybeCred 1 source + |> Task.attempt (CompletedFeedLoad source) + + +sourceName : Source -> String +sourceName source = + case source of + YourFeed _ -> + "Your Feed" + + GlobalFeed -> + "Global Feed" + + TagFeed tagName -> + "#" ++ Tag.toString tagName + + FavoritedFeed username -> + "Favorited Articles" + + AuthorFeed username -> + "My Articles" + + +limit : Source -> Int +limit feedSource = + case feedSource of + YourFeed _ -> + 10 + + GlobalFeed -> + 10 + + TagFeed tagName -> + 10 + + FavoritedFeed username -> + 5 + + AuthorFeed username -> + 5 + + + +-- UPDATE + + +type Msg + = ClickedDismissErrors + | ClickedFavorite Cred Slug + | ClickedUnfavorite Cred Slug + | ClickedFeedPage Int + | ClickedFeedSource Source + | CompletedFavorite (Result Http.Error (Article Preview)) + | CompletedFeedLoad Source (Result Http.Error (PaginatedList (Article Preview))) + + +update : Maybe Cred -> Msg -> Model -> ( Model, Cmd Msg ) +update maybeCred msg (Model model) = + case msg of + ClickedDismissErrors -> + ( Model { model | errors = [] }, Cmd.none ) + + ClickedFeedSource source -> + ( Model { model | isLoading = True } + , source + |> fetch maybeCred 1 + |> Task.attempt (CompletedFeedLoad source) + ) + + CompletedFeedLoad source (Ok articles) -> + ( Model + { model + | articles = articles + , sources = FeedSources.select source model.sources + , isLoading = False + } + , Cmd.none + ) + + CompletedFeedLoad _ (Err error) -> + ( Model + { model + | errors = Api.addServerError model.errors + , isLoading = False + } + , 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 + ) + + ClickedFeedPage page -> + let + source = + FeedSources.selected model.sources + in + ( Model model + , fetch maybeCred page source + |> Task.andThen (\articles -> Task.map (\_ -> articles) scrollToTop) + |> Task.attempt (CompletedFeedLoad source) + ) + + +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 ()) + + +fetch : Maybe Cred -> Int -> Source -> Task Http.Error (PaginatedList (Article Preview)) +fetch maybeCred page feedSource = + let + articlesPerPage = + limit feedSource + + offset = + (page - 1) * articlesPerPage + + params = + [ ( "limit", String.fromInt articlesPerPage ) + , ( "offset", String.fromInt offset ) + ] + in + Task.map (PaginatedList.mapPage (\_ -> page)) <| + case feedSource of + YourFeed cred -> + params + |> buildFromQueryParams (Just cred) (Api.url [ "articles", "feed" ]) + |> Cred.addHeader cred + |> HttpBuilder.toRequest + |> Http.toTask + + GlobalFeed -> + list maybeCred params + + TagFeed tagName -> + list maybeCred (( "tag", Tag.toString tagName ) :: params) + + FavoritedFeed username -> + list maybeCred (( "favorited", Username.toString username ) :: params) + + AuthorFeed username -> + list maybeCred (( "author", Username.toString username ) :: params) + + +list : + Maybe Cred + -> List ( String, String ) + -> Task Http.Error (PaginatedList (Article Preview)) +list maybeCred params = + buildFromQueryParams maybeCred (Api.url [ "articles" ]) params + |> Cred.addHeaderIfAvailable maybeCred + |> HttpBuilder.toRequest + |> Http.toTask + + +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 -> Decoder (PaginatedList (Article Preview)) +decoder maybeCred = + Decode.succeed PaginatedList.fromList + |> required "articlesCount" Decode.int + |> required "articles" (Decode.list (Article.previewDecoder maybeCred)) + + + +-- REQUEST + + +buildFromQueryParams : Maybe Cred -> String -> List ( String, String ) -> RequestBuilder (PaginatedList (Article Preview)) +buildFromQueryParams maybeCred url queryParams = + HttpBuilder.get url + |> withExpect (Http.expectJson (decoder maybeCred)) + |> withQueryParams queryParams + + + +-- INTERNAL + + +fave : (Slug -> Cred -> Http.Request (Article Preview)) -> Cred -> Slug -> InternalModel -> ( Model, Cmd Msg ) +fave toRequest cred slug model = + ( Model model + , toRequest slug cred + |> Http.toTask + |> Task.attempt CompletedFavorite + ) diff --git a/intro/part6/src/Article/FeedSources.elm b/intro/part6/src/Article/FeedSources.elm new file mode 100644 index 0000000..cef87eb --- /dev/null +++ b/intro/part6/src/Article/FeedSources.elm @@ -0,0 +1,109 @@ +module Article.FeedSources exposing (FeedSources, Source(..), after, before, fromLists, select, selected) + +import Article +import Article.Tag as Tag exposing (Tag) +import Username exposing (Username) +import Viewer.Cred as Cred exposing (Cred) + + + +-- TYPES + + +type FeedSources + = FeedSources + { before : List Source + , selected : Source + , after : List Source + } + + +type Source + = YourFeed Cred + | GlobalFeed + | TagFeed Tag + | FavoritedFeed Username + | AuthorFeed Username + + + +-- BUILDING + + +fromLists : Source -> List Source -> FeedSources +fromLists selectedSource afterSources = + FeedSources + { before = [] + , selected = selectedSource + , after = afterSources + } + + + +-- SELECTING + + +select : Source -> FeedSources -> FeedSources +select selectedSource (FeedSources sources) = + let + ( newBefore, newAfter ) = + (sources.before ++ (sources.selected :: sources.after)) + -- By design, tags can only be included if they're selected. + |> List.filter isNotTag + |> splitOn (\source -> source == selectedSource) + in + FeedSources + { before = List.reverse newBefore + , selected = selectedSource + , after = List.reverse newAfter + } + + +splitOn : (Source -> Bool) -> List Source -> ( List Source, List Source ) +splitOn isSelected sources = + let + ( _, newBefore, newAfter ) = + List.foldl (splitOnHelp isSelected) ( False, [], [] ) sources + in + ( newBefore, newAfter ) + + +splitOnHelp : (Source -> Bool) -> Source -> ( Bool, List Source, List Source ) -> ( Bool, List Source, List Source ) +splitOnHelp isSelected source ( foundSelected, beforeSelected, afterSelected ) = + if isSelected source then + ( True, beforeSelected, afterSelected ) + + else if foundSelected then + ( foundSelected, beforeSelected, source :: afterSelected ) + + else + ( foundSelected, source :: beforeSelected, afterSelected ) + + +isNotTag : Source -> Bool +isNotTag currentSource = + case currentSource of + TagFeed _ -> + False + + _ -> + True + + + +-- INFO + + +selected : FeedSources -> Source +selected (FeedSources record) = + record.selected + + +before : FeedSources -> List Source +before (FeedSources record) = + record.before + + +after : FeedSources -> List Source +after (FeedSources record) = + record.after diff --git a/intro/part6/src/Article/Slug.elm b/intro/part6/src/Article/Slug.elm new file mode 100644 index 0000000..723f5f9 --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Article/Tag.elm b/intro/part6/src/Article/Tag.elm new file mode 100644 index 0000000..9fac80b --- /dev/null +++ b/intro/part6/src/Article/Tag.elm @@ -0,0 +1,49 @@ +module Article.Tag exposing (Tag, list, toString, validate) + +import Api +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) + |> Http.get (Api.url [ "tags" ]) + + +validate : String -> List String -> Bool +validate str = + String.split " " str + |> List.map String.trim + |> List.filter (not << String.isEmpty) + |> (==) + + + +-- SERIALIZATION + + +decoder : Decoder Tag +decoder = + Decode.map Tag Decode.string diff --git a/intro/part6/src/Asset.elm b/intro/part6/src/Asset.elm new file mode 100644 index 0000000..f3e7432 --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Author.elm b/intro/part6/src/Author.elm new file mode 100644 index 0000000..e7de3c5 --- /dev/null +++ b/intro/part6/src/Author.elm @@ -0,0 +1,251 @@ +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 +import Html exposing (Html, a, i, text) +import Html.Attributes exposing (attribute, class, href, id, placeholder) +import Html.Events exposing (onClick) +import Http +import HttpBuilder exposing (RequestBuilder, withExpect) +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 Route exposing (Route) +import Username exposing (Username) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + +{-| 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 _ -> + Cred.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 = + Api.url [ "profiles", Username.toString uname ] + |> HttpBuilder.get + |> HttpBuilder.withExpect (Http.expectJson (Decode.field "profile" (decoder maybeCred))) + |> Cred.addHeaderIfAvailable maybeCred + |> HttpBuilder.toRequest + + + +-- 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 = + requestHelp HttpBuilder.post uname cred + + +requestUnfollow : FollowedAuthor -> Cred -> Http.Request Author +requestUnfollow (FollowedAuthor uname _) cred = + requestHelp HttpBuilder.delete uname cred + + +requestHelp : + (String -> RequestBuilder a) + -> Username + -> Cred + -> Http.Request Author +requestHelp builderFromUrl uname cred = + Api.url [ "profiles", Username.toString uname, "follow" ] + |> builderFromUrl + |> Cred.addHeader cred + |> withExpect (Http.expectJson (Decode.field "profile" (decoder Nothing))) + |> HttpBuilder.toRequest + + +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 = + " " ++ 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 == Cred.username cred then + Decode.succeed (IsViewer cred prof) + + else + nonViewerDecoder prof uname + + +nonViewerDecoder : Profile -> Username -> Decoder Author +nonViewerDecoder prof uname = + Decode.field "following" Decode.bool + |> Decode.map (authorFromFollowing prof uname) + + +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/intro/part6/src/Avatar.elm b/intro/part6/src/Avatar.elm new file mode 100644 index 0000000..6c2b123 --- /dev/null +++ b/intro/part6/src/Avatar.elm @@ -0,0 +1,58 @@ +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 + + +src : Avatar -> Attribute msg +src (Avatar maybeUrl) = + Html.Attributes.src (resolveAvatarUrl maybeUrl) + + +resolveAvatarUrl : Maybe String -> String +resolveAvatarUrl maybeUrl = + {- 👉 TODO #1 of 2: return the user's avatar from maybeUrl, if maybeUrl actually + contains one. If maybeUrl is Nothing, return this URL instead: + + https://static.productionready.io/images/smiley-cyrus.jpg + -} + "" + + +encode : Avatar -> Value +encode (Avatar maybeUrl) = + case maybeUrl of + Just url -> + Encode.string url + + Nothing -> + Encode.null + + +toMaybeString : Avatar -> Maybe String +toMaybeString (Avatar maybeUrl) = + maybeUrl diff --git a/intro/part6/src/CommentId.elm b/intro/part6/src/CommentId.elm new file mode 100644 index 0000000..f136e1b --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Email.elm b/intro/part6/src/Email.elm new file mode 100644 index 0000000..f696c01 --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Loading.elm b/intro/part6/src/Loading.elm new file mode 100644 index 0000000..a1ded78 --- /dev/null +++ b/intro/part6/src/Loading.elm @@ -0,0 +1,25 @@ +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/intro/part6/src/Log.elm b/intro/part6/src/Log.elm new file mode 100644 index 0000000..fe6111e --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Main.elm b/intro/part6/src/Main.elm new file mode 100644 index 0000000..cf1c4cc --- /dev/null +++ b/intro/part6/src/Main.elm @@ -0,0 +1,334 @@ +module Main exposing (main) + +import Article.FeedSources as FeedSources +import Article.Slug exposing (Slug) +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.Cred as Cred exposing (Cred) + + + +-- WARNING: Based on discussions around how asset management features +-- like code splitting and lazy loading have been shaping up, I expect +-- most of this file to become unnecessary in a future release of Elm. +-- Avoid putting things in here unless there is no alternative! + + +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 : Value -> Url -> Nav.Key -> ( Model, Cmd Msg ) +init flags url navKey = + changeRouteTo (Route.fromUrl url) + (Redirect (Session.decode navKey flags)) + + + +-- VIEW + + +view : Model -> Document Msg +view model = + let + viewPage page toMsg config = + let + { title, body } = + Page.view (Session.viewer (toSession model)) page config + in + { title = title + , body = List.map (Html.map toMsg) body + } + in + case model of + Redirect _ -> + viewPage Page.Other (\_ -> Ignored) Blank.view + + NotFound _ -> + viewPage Page.Other (\_ -> Ignored) 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 + = Ignored + | ChangedRoute (Maybe Route) + | 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, Session.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 + ( Ignored, _ ) -> + ( model, Cmd.none ) + + ( 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 + + ( ChangedRoute route, _ ) -> + changeRouteTo route 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 = + Browser.application + { init = init + , onUrlChange = ChangedUrl + , onUrlRequest = ClickedLink + , subscriptions = subscriptions + , update = update + , view = view + } diff --git a/intro/part6/src/Page.elm b/intro/part6/src/Page.elm new file mode 100644 index 0000000..2986b9c --- /dev/null +++ b/intro/part6/src/Page.elm @@ -0,0 +1,159 @@ +module Page exposing (Page(..), view, viewErrors) + +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) +import Viewer.Cred as Cred exposing (Cred) + + +{-| 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 + cred = + Viewer.cred viewer + + username = + Cred.username cred + + avatar = + Profile.avatar (Viewer.profile viewer) + in + [ linkTo Route.NewArticle [ i [ class "ion-compose" ] [], text " New Post" ] + , linkTo Route.Settings [ i [ class "ion-gear-a" ] [], text " 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/intro/part6/src/Page/Article.elm b/intro/part6/src/Page/Article.elm new file mode 100644 index 0000000..d454f5f --- /dev/null +++ b/intro/part6/src/Page/Article.elm @@ -0,0 +1,588 @@ +module Page.Article exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| Viewing an individual article. +-} + +import Api +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) +import Html.Events exposing (onClick, onInput, onSubmit) +import Http +import HttpBuilder exposing (RequestBuilder, withBody, withExpect, withQueryParams) +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) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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 = + Profile.avatar (Viewer.profile 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 + ] + [] + ] + , 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 = + Article.url slug [] + |> HttpBuilder.delete + |> Cred.addHeader cred + |> HttpBuilder.toRequest + + + +-- 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/intro/part6/src/Page/Article/Editor.elm b/intro/part6/src/Page/Article/Editor.elm new file mode 100644 index 0000000..04a89e4 --- /dev/null +++ b/intro/part6/src/Page/Article/Editor.elm @@ -0,0 +1,641 @@ +module Page.Article.Editor exposing (Model, Msg, initEdit, initNew, subscriptions, toSession, update, view) + +import Api +import Article exposing (Article, Full) +import Article.Body exposing (Body) +import Article.Slug as Slug exposing (Slug) +import Article.Tag +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 HttpBuilder exposing (withBody, withExpect) +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 +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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 if String.trim form.tags /= "" && List.all String.isEmpty (toTagList form.tags) then + [ "close, but not quite! Is your filter condition returning True when it should be returning False?" ] + + else if Article.Tag.validate form.tags (toTagList form.tags) then + [] + + else + [ "some tags were empty." ] + + +{-| 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 + expect = + Article.fullDecoder (Just cred) + |> Decode.field "article" + |> Http.expectJson + + article = + Encode.object + [ ( "title", Encode.string form.title ) + , ( "description", Encode.string form.description ) + , ( "body", Encode.string form.body ) + , ( "tagList", Encode.list Encode.string (toTagList form.tags) ) + ] + + jsonBody = + Encode.object [ ( "article", article ) ] + |> Http.jsonBody + in + Api.url [ "articles" ] + |> HttpBuilder.post + |> Cred.addHeader cred + |> withBody jsonBody + |> withExpect expect + |> HttpBuilder.toRequest + + +toTagList : String -> List String +toTagList tagString = + {- 👉 TODO #2 of 2: add another |> to the end of this pipeline, + which filters out any remaining empty strings. + + To see if the bug is fixed, visit http://localhost:3000/#/editor + (you'll need to be logged in) and create an article with tags that have + multiple spaces between them, e.g. "tag1 tag2 tag3" + + If the bug has not been fixed, trying to save an article with those tags + will result in an error! If it has been fixed, saving will work and the + tags will be accepted. + + 💡 HINT: Here's how to remove all the "foo" strings from a list of strings: + + List.filter (\str -> str == "foo") listOfStrings + -} + String.split " " tagString + |> List.map String.trim + + +edit : Slug -> TrimmedForm -> Cred -> Http.Request (Article Full) +edit articleSlug (Trimmed form) cred = + let + expect = + Article.fullDecoder (Just cred) + |> Decode.field "article" + |> Http.expectJson + + article = + Encode.object + [ ( "title", Encode.string form.title ) + , ( "description", Encode.string form.description ) + , ( "body", Encode.string form.body ) + ] + + jsonBody = + Encode.object [ ( "article", article ) ] + |> Http.jsonBody + in + Article.url articleSlug [] + |> HttpBuilder.put + |> Cred.addHeader cred + |> withBody jsonBody + |> withExpect expect + |> HttpBuilder.toRequest + + + +-- 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/intro/part6/src/Page/Blank.elm b/intro/part6/src/Page/Blank.elm new file mode 100644 index 0000000..3ae45a3 --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Page/Home.elm b/intro/part6/src/Page/Home.elm new file mode 100644 index 0000000..a4dea6d --- /dev/null +++ b/intro/part6/src/Page/Home.elm @@ -0,0 +1,259 @@ +module Page.Home exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| The homepage. You can get here via either the / or /#/ routes. +-} + +import Article +import Article.Feed as Feed +import Article.FeedSources as FeedSources exposing (FeedSources, Source(..)) +import Article.Tag as Tag exposing (Tag) +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 Session exposing (Session) +import Task exposing (Task) +import Time +import Viewer.Cred as Cred exposing (Cred) + + + +-- MODEL + + +type alias Model = + { session : Session + , timeZone : Time.Zone + + -- Loaded independently from server + , tags : Status (List Tag) + , feed : Status Feed.Model + } + + +type Status a + = Loading + | LoadingSlowly + | Loaded a + | Failed + + +init : Session -> ( Model, Cmd Msg ) +init session = + let + feedSources = + case Session.cred session of + Just cred -> + FeedSources.fromLists (YourFeed cred) [ GlobalFeed ] + + Nothing -> + FeedSources.fromLists GlobalFeed [] + + loadTags = + Tag.list + |> Http.toTask + in + ( { session = session + , timeZone = Time.utc + , tags = Loading + , feed = Loading + } + , Cmd.batch + [ Feed.init session feedSources + |> 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 -> + viewFeed model.timeZone 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." ] + ] + ] + + +viewFeed : Time.Zone -> Feed.Model -> List (Html Msg) +viewFeed timeZone feed = + div [ class "feed-toggle" ] + [ Feed.viewFeedSources feed |> Html.map GotFeedMsg ] + :: (Feed.viewArticles timeZone feed |> List.map (Html.map GotFeedMsg)) + + +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 + | 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 tagName -> + let + subCmd = + Feed.selectTag (Session.cred model.session) tagName + in + ( model, Cmd.map GotFeedMsg subCmd ) + + 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 ) + + + +-- 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/intro/part6/src/Page/Login.elm b/intro/part6/src/Page/Login.elm new file mode 100644 index 0000000..c180017 --- /dev/null +++ b/intro/part6/src/Page/Login.elm @@ -0,0 +1,317 @@ +module Page.Login exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| The login page. +-} + +import Api +import Browser.Navigation as Nav +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Http +import Json.Decode as Decode exposing (Decoder, decodeString, field, string) +import Json.Decode.Pipeline exposing (optional) +import Json.Encode as Encode +import Route exposing (Route) +import Session exposing (Session) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- MODEL + + +type alias Model = + { session : Session + , problems : List Problem + , form : Form + } + + +{-| 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 + , Session.login viewer + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none and +Ignored. Useful for recording form fields! +-} +updateForm : (Form -> Form) -> Model -> ( Model, Cmd Msg ) +updateForm transform model = + ( { model | form = transform model.form }, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- 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 + Decode.field "user" Viewer.decoder + |> Http.post (Api.url [ "users", "login" ]) body + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session diff --git a/intro/part6/src/Page/NotFound.elm b/intro/part6/src/Page/NotFound.elm new file mode 100644 index 0000000..e0c534b --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Page/Profile.elm b/intro/part6/src/Page/Profile.elm new file mode 100644 index 0000000..af86830 --- /dev/null +++ b/intro/part6/src/Page/Profile.elm @@ -0,0 +1,346 @@ +module Page.Profile exposing (Model, Msg, init, subscriptions, toSession, update, view) + +{-| An Author's profile. +-} + +import Article.Feed as Feed +import Article.FeedSources as FeedSources exposing (FeedSources, Source(..)) +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 Profile exposing (Profile) +import Route +import Session exposing (Session) +import Task exposing (Task) +import Time +import Username exposing (Username) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- MODEL + + +type alias Model = + { session : Session + , timeZone : Time.Zone + , errors : List String + + -- Loaded independently from server + , author : Status Author + , feed : Status Feed.Model + } + + +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 = [] + , author = Loading username + , feed = Loading username + } + , Cmd.batch + [ Author.fetch username maybeCred + |> Http.toTask + |> Task.mapError (Tuple.pair username) + |> Task.attempt CompletedAuthorLoad + , defaultFeedSources username + |> Feed.init session + |> Task.mapError (Tuple.pair username) + |> Task.attempt CompletedFeedLoad + , Task.perform GotTimeZone Time.here + , Task.perform (\_ -> PassedSlowLoadThreshold) Loading.slowThreshold + ] + ) + + + +-- 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" ] [ viewFeed model.timeZone 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 == Cred.username cred then + myProfileTitle + + else + defaultTitle + + Nothing -> + defaultTitle + + +myProfileTitle : String +myProfileTitle = + "My Profile" + + +defaultTitle : String +defaultTitle = + "Profile" + + + +-- FEED + + +viewFeed : Time.Zone -> Feed.Model -> Html Msg +viewFeed timeZone feed = + div [ class "col-xs-12 col-md-10 offset-md-1" ] <| + div [ class "articles-toggle" ] + [ Feed.viewFeedSources feed |> Html.map GotFeedMsg ] + :: (Feed.viewArticles timeZone feed |> List.map (Html.map GotFeedMsg)) + + + +-- UPDATE + + +type Msg + = ClickedDismissErrors + | ClickedFollow Cred UnfollowedAuthor + | ClickedUnfollow Cred FollowedAuthor + | 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 + ) + + 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 + + + +-- INTERNAL + + +defaultFeedSources : Username -> FeedSources +defaultFeedSources username = + FeedSources.fromLists (AuthorFeed username) [ FavoritedFeed username ] diff --git a/intro/part6/src/Page/Register.elm b/intro/part6/src/Page/Register.elm new file mode 100644 index 0000000..f2f31e2 --- /dev/null +++ b/intro/part6/src/Page/Register.elm @@ -0,0 +1,319 @@ +module Page.Register exposing (Model, Msg, init, subscriptions, toSession, update, view) + +import Api +import Browser.Navigation as Nav +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import Http +import Json.Decode as Decode exposing (Decoder, decodeString, field, string) +import Json.Decode.Pipeline exposing (optional) +import Json.Encode as Encode +import Route exposing (Route) +import Session exposing (Session) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- MODEL + + +type alias Model = + { session : Session + , problems : List Problem + , form : Form + } + + +type alias Form = + { email : String + , username : String + , password : String + } + + +type Problem + = InvalidEntry ValidatedField String + | ServerError String + + +init : Session -> ( Model, Cmd msg ) +init session = + ( { session = session + , problems = [] + , form = + { email = "" + , username = "" + , password = "" + } + } + , Cmd.none + ) + + + +-- VIEW + + +view : Model -> { title : String, content : Html Msg } +view model = + { title = "Register" + , content = + div [ class "cred-page" ] + [ div [ class "container page" ] + [ div [ class "row" ] + [ div [ class "col-md-6 offset-md-3 col-xs-12" ] + [ h1 [ class "text-xs-center" ] [ text "Sign up" ] + , p [ class "text-xs-center" ] + [ a [ Route.href Route.Login ] + [ text "Have an account?" ] + ] + , ul [ class "error-messages" ] + (List.map viewProblem model.problems) + , viewForm model.form + ] + ] + ] + ] + } + + +viewForm : Form -> Html Msg +viewForm form = + Html.form [ onSubmit SubmittedForm ] + [ fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , placeholder "Username" + , onInput EnteredUsername + , value form.username + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , placeholder "Email" + , onInput EnteredEmail + , value form.email + ] + [] + ] + , fieldset [ class "form-group" ] + [ input + [ class "form-control form-control-lg" + , type_ "password" + , placeholder "Password" + , onInput EnteredPassword + , value form.password + ] + [] + ] + , button [ class "btn btn-lg btn-primary pull-xs-right" ] + [ text "Sign up" ] + ] + + +viewProblem : Problem -> Html msg +viewProblem problem = + let + errorMessage = + case problem of + InvalidEntry _ str -> + str + + ServerError str -> + str + in + li [] [ text errorMessage ] + + + +-- UPDATE + + +type Msg + = SubmittedForm + | EnteredEmail String + | EnteredUsername String + | EnteredPassword String + | CompletedRegister (Result Http.Error Viewer) + | GotSession Session + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + SubmittedForm -> + case validate model.form of + Ok validForm -> + ( { model | problems = [] } + , Http.send CompletedRegister (register validForm) + ) + + Err problems -> + ( { model | problems = problems } + , Cmd.none + ) + + EnteredUsername username -> + updateForm (\form -> { form | username = username }) model + + EnteredEmail email -> + updateForm (\form -> { form | email = email }) model + + EnteredPassword password -> + updateForm (\form -> { form | password = password }) model + + CompletedRegister (Err error) -> + let + serverErrors = + Api.decodeErrors error + |> List.map ServerError + in + ( { model | problems = List.append model.problems serverErrors } + , Cmd.none + ) + + CompletedRegister (Ok viewer) -> + ( model + , Session.login viewer + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none and +Ignored. Useful for recording form fields! +-} +updateForm : (Form -> Form) -> Model -> ( Model, Cmd Msg ) +updateForm transform model = + ( { model | form = transform model.form }, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session + + + +-- FORM + + +{-| Marks that we've trimmed the form's fields, so we don't accidentally send +it to the server without having trimmed it! +-} +type TrimmedForm + = Trimmed Form + + +{-| When adding a variant here, add it to `fieldsToValidate` too! +-} +type ValidatedField + = Username + | Email + | Password + + +fieldsToValidate : List ValidatedField +fieldsToValidate = + [ Username + , Email + , Password + ] + + +{-| Trim the form and validate its fields. If there are problems, report them! +-} +validate : Form -> Result (List Problem) TrimmedForm +validate form = + let + trimmedForm = + trimFields form + in + case List.concatMap (validateField trimmedForm) fieldsToValidate of + [] -> + Ok trimmedForm + + problems -> + Err problems + + +validateField : TrimmedForm -> ValidatedField -> List Problem +validateField (Trimmed form) field = + List.map (InvalidEntry field) <| + case field of + Username -> + if String.isEmpty form.username then + [ "username can't be blank." ] + + else + [] + + Email -> + if String.isEmpty form.email then + [ "email can't be blank." ] + + else + [] + + Password -> + if String.isEmpty form.password then + [ "password can't be blank." ] + + else if String.length form.password < Viewer.minPasswordChars then + [ "password must be at least " ++ String.fromInt Viewer.minPasswordChars ++ " characters long." ] + + else + [] + + +{-| Don't trim while the user is typing! That would be super annoying. +Instead, trim only on submit. +-} +trimFields : Form -> TrimmedForm +trimFields form = + Trimmed + { username = String.trim form.username + , email = String.trim form.email + , password = String.trim form.password + } + + + +-- HTTP + + +register : TrimmedForm -> Http.Request Viewer +register (Trimmed form) = + let + user = + Encode.object + [ ( "username", Encode.string form.username ) + , ( "email", Encode.string form.email ) + , ( "password", Encode.string form.password ) + ] + + body = + Encode.object [ ( "user", user ) ] + |> Http.jsonBody + in + Decode.field "user" Viewer.decoder + |> Http.post (Api.url [ "users" ]) body diff --git a/intro/part6/src/Page/Settings.elm b/intro/part6/src/Page/Settings.elm new file mode 100644 index 0000000..fdea129 --- /dev/null +++ b/intro/part6/src/Page/Settings.elm @@ -0,0 +1,434 @@ +module Page.Settings exposing (Model, Msg, init, subscriptions, toSession, update, view) + +import Api +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 HttpBuilder +import Json.Decode as Decode exposing (Decoder, decodeString, field, list, string) +import Json.Decode.Pipeline exposing (optional) +import Json.Encode as Encode +import Profile exposing (Profile) +import Route +import Session exposing (Session) +import Username as Username exposing (Username) +import Viewer exposing (Viewer) +import Viewer.Cred as Cred exposing (Cred) + + + +-- MODEL + + +type alias Model = + { session : Session + , problems : List Problem + , form : Form + } + + +type alias Form = + { avatar : String + , bio : String + , email : String + , username : String + , password : String + } + + +type Problem + = InvalidEntry ValidatedField String + | ServerError String + + +init : Session -> ( Model, Cmd msg ) +init session = + ( { session = session + , problems = [] + , form = + case Session.viewer session of + Just viewer -> + let + profile = + Viewer.profile viewer + + cred = + Viewer.cred viewer + in + { avatar = Maybe.withDefault "" (Avatar.toMaybeString (Profile.avatar profile)) + , email = Email.toString (Viewer.email viewer) + , bio = Maybe.withDefault "" (Profile.bio profile) + , username = Username.toString (Cred.username cred) + , password = "" + } + + Nothing -> + -- It's fine to store a blank form here. You won't be + -- able to submit it if you're not logged in anyway. + { avatar = "" + , email = "" + , bio = "" + , username = "" + , password = "" + } + } + , Cmd.none + ) + + +{-| 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) + , viewForm cred model.form + ] + ] + ] + ] + + Nothing -> + text "Sign in to view your settings." + } + + +viewForm : Cred -> Form -> Html Msg +viewForm cred form = + Html.form [ onSubmit (SubmittedForm cred) ] + [ 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 + | EnteredEmail String + | EnteredUsername String + | EnteredPassword String + | EnteredBio String + | EnteredAvatar String + | CompletedSave (Result Http.Error Viewer) + | GotSession Session + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + SubmittedForm cred -> + case validate model.form of + Ok validForm -> + ( { model | problems = [] } + , 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 cred) -> + ( model + , Session.login cred + ) + + GotSession session -> + ( { model | session = session } + , Route.replaceUrl (Session.navKey session) Route.Home + ) + + +{-| Helper function for `update`. Updates the form and returns Cmd.none and +Ignored. Useful for recording form fields! +-} +updateForm : (Form -> Form) -> Model -> ( Model, Cmd Msg ) +updateForm transform model = + ( { model | form = transform model.form }, Cmd.none ) + + + +-- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions model = + Session.changes GotSession (Session.navKey model.session) + + + +-- EXPORT + + +toSession : Model -> Session +toSession model = + model.session + + + +-- FORM + + +{-| Marks that we've trimmed the form's fields, so we don't accidentally send +it to the server without having trimmed it! +-} +type TrimmedForm + = Trimmed Form + + +{-| When adding a variant here, add it to `fieldsToValidate` too! + +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 + + expect = + Decode.field "user" Viewer.decoder + |> Http.expectJson + in + Api.url [ "user" ] + |> HttpBuilder.put + |> HttpBuilder.withExpect expect + |> HttpBuilder.withBody body + |> Cred.addHeader cred + |> HttpBuilder.toRequest + + +nothingIfEmpty : String -> Maybe String +nothingIfEmpty str = + if String.isEmpty str then + Nothing + + else + Just str diff --git a/intro/part6/src/PaginatedList.elm b/intro/part6/src/PaginatedList.elm new file mode 100644 index 0000000..9e73e71 --- /dev/null +++ b/intro/part6/src/PaginatedList.elm @@ -0,0 +1,98 @@ +module PaginatedList exposing (PaginatedList, fromList, map, mapPage, page, total, values, view) + +import Html exposing (Html, a, li, text, ul) +import Html.Attributes exposing (class, classList, href) +import Html.Events exposing (onClick) + + + +-- TYPES + + +type PaginatedList a + = PaginatedList + { values : List a + , total : Int + , page : Int + } + + + +-- INFO + + +values : PaginatedList a -> List a +values (PaginatedList info) = + info.values + + +total : PaginatedList a -> Int +total (PaginatedList info) = + info.total + + +page : PaginatedList a -> Int +page (PaginatedList info) = + info.page + + + +-- CREATE + + +fromList : Int -> List a -> PaginatedList a +fromList totalCount list = + PaginatedList { values = list, total = totalCount, page = 1 } + + + +-- TRANSFORM + + +map : (a -> a) -> PaginatedList a -> PaginatedList a +map transform (PaginatedList info) = + PaginatedList { info | values = List.map transform info.values } + + +mapPage : (Int -> Int) -> PaginatedList a -> PaginatedList a +mapPage transform (PaginatedList info) = + PaginatedList { info | page = transform info.page } + + + +-- VIEW + + +view : (Int -> msg) -> PaginatedList a -> Int -> Html msg +view toMsg list resultsPerPage = + let + totalPages = + ceiling (toFloat (total list) / toFloat resultsPerPage) + + activePage = + page list + + viewPageLink currentPage = + pageLink toMsg currentPage (currentPage == activePage) + 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) ] + ] diff --git a/intro/part6/src/Profile.elm b/intro/part6/src/Profile.elm new file mode 100644 index 0000000..e8e32e7 --- /dev/null +++ b/intro/part6/src/Profile.elm @@ -0,0 +1,56 @@ +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 +import Avatar exposing (Avatar) +import Http +import HttpBuilder exposing (RequestBuilder, withExpect) +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (required) +import Username exposing (Username) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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/intro/part6/src/Route.elm b/intro/part6/src/Route.elm new file mode 100644 index 0000000..1e524fe --- /dev/null +++ b/intro/part6/src/Route.elm @@ -0,0 +1,107 @@ +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 = + let + pieces = + 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 ] + in + "#/" ++ String.join "/" pieces diff --git a/intro/part6/src/Session.elm b/intro/part6/src/Session.elm new file mode 100644 index 0000000..ee70a0c --- /dev/null +++ b/intro/part6/src/Session.elm @@ -0,0 +1,116 @@ +port module Session + exposing + ( Session + , changes + , cred + , decode + , login + , logout + , navKey + , viewer + ) + +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) +import Viewer.Cred as Cred exposing (Cred) + + + +-- 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 + + + +-- LOGIN + + +login : Viewer -> Cmd msg +login newViewer = + Viewer.encode newViewer + |> Encode.encode 0 + |> Just + |> storeSession + + + +-- LOGOUT + + +logout : Cmd msg +logout = + storeSession Nothing + + +port storeSession : Maybe String -> Cmd msg + + + +-- CHANGES + + +changes : (Session -> msg) -> Nav.Key -> Sub msg +changes toMsg key = + onSessionChange (\val -> toMsg (decode key val)) + + +port onSessionChange : (Value -> msg) -> Sub msg + + +decode : Nav.Key -> Value -> Session +decode key value = + -- It's stored in localStorage as a JSON String; + -- first decode the Value as a String, then + -- decode that String as JSON. + case + Decode.decodeValue Decode.string value + |> Result.andThen (Decode.decodeString Viewer.decoder) + |> Result.toMaybe + of + Just decodedViewer -> + LoggedIn key decodedViewer + + Nothing -> + Guest key diff --git a/intro/part6/src/Timestamp.elm b/intro/part6/src/Timestamp.elm new file mode 100644 index 0000000..fde03e0 --- /dev/null +++ b/intro/part6/src/Timestamp.elm @@ -0,0 +1,100 @@ +module Timestamp exposing (format, iso8601Decoder, view) + +import Html exposing (Html, span, text) +import Html.Attributes exposing (class) +import Iso8601 +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) ] + + + +-- DECODE + + +{-| Decode an ISO-8601 date string. +-} +iso8601Decoder : Decoder Time.Posix +iso8601Decoder = + Decode.string + |> Decode.andThen fromString + + +fromString : String -> Decoder Time.Posix +fromString str = + case Iso8601.toTime str of + Ok successValue -> + succeed successValue + + Err _ -> + fail ("Invalid date: " ++ str) + + + +-- 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/intro/part6/src/Username.elm b/intro/part6/src/Username.elm new file mode 100644 index 0000000..a7f17ec --- /dev/null +++ b/intro/part6/src/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/intro/part6/src/Viewer.elm b/intro/part6/src/Viewer.elm new file mode 100644 index 0000000..7ecfedb --- /dev/null +++ b/intro/part6/src/Viewer.elm @@ -0,0 +1,85 @@ +module Viewer exposing (Viewer, cred, decoder, email, encode, minPasswordChars, profile) + +{-| The logged-in user currently viewing this page. +-} + +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) +import Viewer.Cred as Cred exposing (Cred) + + + +-- TYPES + + +type Viewer + = Viewer Internals + + +type alias Internals = + { cred : Cred + , profile : Profile + , email : Email + } + + + +-- INFO + + +cred : Viewer -> Cred +cred (Viewer info) = + info.cred + + +profile : Viewer -> Profile +profile (Viewer info) = + info.profile + + +email : Viewer -> Email +email (Viewer info) = + info.email + + +{-| Passwords must be at least this many characters long! +-} +minPasswordChars : Int +minPasswordChars = + 6 + + + +-- SERIALIZATION + + +encode : Viewer -> Value +encode (Viewer info) = + Encode.object + [ ( "email", Email.encode info.email ) + , ( "username", Username.encode (Cred.username info.cred) ) + , ( "image", Avatar.encode (Profile.avatar info.profile) ) + , ( "token", Cred.encodeToken info.cred ) + , ( "bio" + , case Profile.bio info.profile of + Just bio -> + Encode.string bio + + Nothing -> + Encode.null + ) + ] + + +decoder : Decoder Viewer +decoder = + Decode.succeed Internals + |> custom Cred.decoder + |> custom Profile.decoder + |> required "email" Email.decoder + |> Decode.map Viewer diff --git a/intro/part6/src/Viewer/Cred.elm b/intro/part6/src/Viewer/Cred.elm new file mode 100644 index 0000000..d010acc --- /dev/null +++ b/intro/part6/src/Viewer/Cred.elm @@ -0,0 +1,85 @@ +module Viewer.Cred exposing (Cred, addHeader, addHeaderIfAvailable, decoder, encodeToken, username) + +{-| 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! + +-} + +import HttpBuilder exposing (RequestBuilder, withHeader) +import Json.Decode as Decode exposing (Decoder) +import Json.Decode.Pipeline exposing (required) +import Json.Encode as Encode exposing (Value) +import Username exposing (Username) + + +{-| The authentication token for the currently logged-in user. + +The token records the username associated with this token, which you can ask it for. + +By design, there is no way to access the token directly as a String. You can encode it for persistence, and you can add it to a header to a HttpBuilder for a request, but that's it. + +-} + + + +-- TYPES + + +type Cred + = Cred Username String + + + +-- INFO + + +username : Cred -> Username +username (Cred val _) = + val + + + +-- SERIALIZATION + + +decoder : Decoder Cred +decoder = + Decode.succeed Cred + |> required "username" Username.decoder + |> required "token" Decode.string + + + +-- TRANSFORM + + +encodeToken : Cred -> Value +encodeToken (Cred _ str) = + Encode.string str + + +addHeader : Cred -> RequestBuilder a -> RequestBuilder a +addHeader (Cred _ str) builder = + builder + |> withHeader "authorization" ("Token " ++ str) + + +addHeaderIfAvailable : Maybe Cred -> RequestBuilder a -> RequestBuilder a +addHeaderIfAvailable maybeCred builder = + case maybeCred of + Just cred -> + addHeader cred builder + + Nothing -> + builder