Re-add part3

This commit is contained in:
Richard Feldman
2018-08-13 06:17:49 -04:00
parent 3002567065
commit df15488e97
36 changed files with 5796 additions and 0 deletions

View File

@@ -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

View File

@@ -0,0 +1,320 @@
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 <https://youtu.be/x1FU3e0sT1I> - now you know why!
)
-}
type alias Metadata =
{ description : String
, title : String
, tags : List String
, createdAt : Time.Posix
, favorited : Bool
, favoritesCount : Int
}
type alias Internals =
{ slug : Slug
, author : Author
, metadata : Metadata
}
type Preview
= Preview
type Full
= Full Body
-- INFO
author : Article a -> Author
author (Article internals _) =
internals.author
metadata : Article a -> Metadata
metadata (Article internals _) =
internals.metadata
slug : Article a -> Slug
slug (Article internals _) =
internals.slug
body : Article Full -> Body
body (Article _ (Full extraInfo)) =
extraInfo
-- TRANSFORM
{-| This is the only way you can transform an existing article:
you can change its author (e.g. to follow or unfollow them).
All other article data necessarily comes from the server!
We can tell this for sure by looking at the types of the exposed functions
in this module.
-}
mapAuthor : (Author -> Author) -> Article a -> Article a
mapAuthor transform (Article info extras) =
Article { info | author = transform info.author } extras
fromPreview : Body -> Article Preview -> Article Full
fromPreview newBody (Article info Preview) =
Article info (Full newBody)
-- SERIALIZATION
previewDecoder : Maybe Cred -> Decoder (Article Preview)
previewDecoder maybeCred =
Decode.succeed Article
|> custom (internalsDecoder maybeCred)
|> hardcoded Preview
fullDecoder : Maybe Cred -> Decoder (Article Full)
fullDecoder maybeCred =
Decode.succeed Article
|> custom (internalsDecoder maybeCred)
|> required "body" (Decode.map Full Body.decoder)
internalsDecoder : Maybe Cred -> Decoder Internals
internalsDecoder maybeCred =
Decode.succeed Internals
|> required "slug" Slug.decoder
|> required "author" (Author.decoder maybeCred)
|> custom metadataDecoder
metadataDecoder : Decoder Metadata
metadataDecoder =
Decode.succeed Metadata
|> required "description" (Decode.map (Maybe.withDefault "") (Decode.nullable Decode.string))
|> required "title" Decode.string
|> required "tagList" (Decode.list Decode.string)
|> required "createdAt" 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)

View File

@@ -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

View File

@@ -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)

View File

@@ -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 <https://www.youtube.com/watch?v=DoA4Txr4GUs>
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
)

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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 ]

View File

@@ -0,0 +1,56 @@
module Avatar exposing (Avatar, decoder, encode, src, toMaybeString)
import Asset
import Html exposing (Attribute)
import Html.Attributes
import Json.Decode as Decode exposing (Decoder)
import Json.Encode as Encode exposing (Value)
-- TYPES
type Avatar
= Avatar (Maybe String)
-- CREATE
decoder : Decoder Avatar
decoder =
Decode.map Avatar (Decode.nullable Decode.string)
-- TRANSFORM
encode : Avatar -> Value
encode (Avatar maybeUrl) =
case maybeUrl of
Just url ->
Encode.string url
Nothing ->
Encode.null
src : Avatar -> Attribute msg
src (Avatar maybeUrl) =
case maybeUrl of
Nothing ->
Asset.src Asset.defaultAvatar
Just "" ->
Asset.src Asset.defaultAvatar
Just url ->
Html.Attributes.src url
toMaybeString : Avatar -> Maybe String
toMaybeString (Avatar maybeUrl) =
maybeUrl

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -0,0 +1,20 @@
module Log exposing (error)
{-| This is a placeholder API for how we might do logging through
some service like <http://rollbar.com> (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

334
advanced/part3/src/Main.elm Normal file
View File

@@ -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
}

159
advanced/part3/src/Page.elm Normal file
View File

@@ -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" ] ]

View File

@@ -0,0 +1,597 @@
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
{- 👉 TODO: Oops! These are all `Task` values, not `Cmd` values!
Use `|> Task.attempt` and `|> Task.perform` to make this compile.
Relevant docs:
https://alpha.elm-lang.org/packages/elm/core/latest/Task#attempt
https://alpha.elm-lang.org/packages/elm/core/latest/Task#perform
-}
[ Article.fetch maybeCred slug
|> Http.toTask
, Comment.list maybeCred slug
|> Http.toTask
, Time.here
, 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" ]

View File

@@ -0,0 +1,620 @@
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 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
[]
{-| 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 (tagsFromString form.tags) )
]
jsonBody =
Encode.object [ ( "article", article ) ]
|> Http.jsonBody
in
Api.url [ "articles" ]
|> HttpBuilder.post
|> Cred.addHeader cred
|> withBody jsonBody
|> withExpect expect
|> HttpBuilder.toRequest
tagsFromString : String -> List String
tagsFromString str =
String.split " " str
|> List.map String.trim
|> List.filter (not << String.isEmpty)
edit : Slug -> TrimmedForm -> Cred -> Http.Request (Article Full)
edit articleSlug (Trimmed form) cred =
let
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

View File

@@ -0,0 +1,10 @@
module Page.Blank exposing (view)
import Html exposing (Html)
view : { title : String, content : Html msg }
view =
{ title = ""
, content = Html.text ""
}

View File

@@ -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

View File

@@ -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

View File

@@ -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 ] [] ]
]
}

View File

@@ -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 ]

View File

@@ -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

View File

@@ -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

View File

@@ -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) ]
]

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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:
<https://package.elm-lang.org/packages/ryannhg/date-format/latest/>
-}
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

View File

@@ -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

View File

@@ -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

View File

@@ -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