diff --git a/src/Api.elm b/src/Api.elm index adce6e82be..b60c3e9cdb 100644 --- a/src/Api.elm +++ b/src/Api.elm @@ -1,4 +1,4 @@ -port module Api exposing (Cred, addServerError, application, decodeErrors, delete, get, login, logout, post, put, register, settings, storeCredWith, username, viewerChanges) +port module Api exposing (Cred, addServerError, application, decodeErrors, delete, get, login, logout, post, put, register, settings, storageDecoder, storeCredWith, username, viewerChanges) {-| This module is responsible for communicating to the Conduit API. diff --git a/src/Article/Feed.elm b/src/Article/Feed.elm index 8e4f4bd1a0..dfca51861d 100644 --- a/src/Article/Feed.elm +++ b/src/Article/Feed.elm @@ -22,6 +22,7 @@ import Time import Timestamp import Url exposing (Url) import Username exposing (Username) +import View {-| NOTE: This module has its own Model, view, and update. This is not normal! @@ -85,7 +86,7 @@ viewArticles timeZone (Model { articles, session, errors }) = PaginatedList.values articles |> List.map (viewPreview maybeCred timeZone) in - Page.viewErrors ClickedDismissErrors errors :: articlesHtml + View.viewErrors ClickedDismissErrors errors :: articlesHtml viewPreview : Maybe Cred -> Time.Zone -> Article Preview -> Html Msg diff --git a/src/Main.elm b/src/Main.elm index 8899c6f886..9e82adb962 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -14,12 +14,14 @@ import Page.Article.Editor as Editor import Page.Blank as Blank import Page.Home as Home import Page.Login as Login +import Page.Logout as Logout 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 Spa import Spa.PageStack import Task import Time @@ -30,20 +32,6 @@ import Viewer exposing (Viewer) --- NOTE: Based on discussions around how asset management features --- like code splitting and lazy loading have been shaping up, it's possible --- that most of this file may become unnecessary in a future release of Elm. --- Avoid putting things in this module unless there is no alternative! --- See https://discourse.elm-lang.org/t/elm-spa-in-0-19/1800/2 for more. - - -type Model - = Redirect Session - | NotFound Session - | Stack Session StackModel - - - -- Elm SPA pages @@ -52,29 +40,33 @@ type alias StackModel = type alias StackCurrentModel = - Editor.Model + Logout.Model type alias StackPreviousModel = Spa.PageStack.Model Never - Article.Model + Editor.Model (Spa.PageStack.Model Never - Register.Model + Article.Model (Spa.PageStack.Model Never - Login.Model + Register.Model (Spa.PageStack.Model Never - Profile.Model + Login.Model (Spa.PageStack.Model Never - Settings.Model + Profile.Model (Spa.PageStack.Model Never - Home.Model - (Spa.PageStack.Model Never () ()) + Settings.Model + (Spa.PageStack.Model + Never + Home.Model + (Spa.PageStack.Model Never () ()) + ) ) ) ) @@ -87,26 +79,30 @@ type alias StackMsg = type alias StackCurrentMsg = - Editor.Msg + Logout.Msg type alias StackPreviousMsg = Spa.PageStack.Msg Route - Article.Msg + Editor.Msg (Spa.PageStack.Msg Route - Register.Msg + Article.Msg (Spa.PageStack.Msg Route - Login.Msg + Register.Msg (Spa.PageStack.Msg Route - Profile.Msg + Login.Msg (Spa.PageStack.Msg Route - Settings.Msg - (Spa.PageStack.Msg Route Home.Msg (Spa.PageStack.Msg Route () ())) + Profile.Msg + (Spa.PageStack.Msg + Route + Settings.Msg + (Spa.PageStack.Msg Route Home.Msg (Spa.PageStack.Msg Route () ())) + ) ) ) ) @@ -117,208 +113,43 @@ type alias Stack = Spa.PageStack.Stack Never Session Session.Msg Route (View StackMsg) StackCurrentModel StackPreviousModel StackCurrentMsg StackPreviousMsg -stack : Stack -stack = - Spa.PageStack.setup { defaultView = View.default } - |> Spa.PageStack.add ( View.map, View.map ) Route.matchHome (Home.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchSettings (Settings.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchProfile (Profile.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchLogin (Login.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchRegister (Register.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchArticle (Article.page >> Ok) - |> Spa.PageStack.add ( View.map, View.map ) Route.matchEditor (Editor.page >> Ok) - - - --- MODEL - - -init : Maybe Viewer -> Url -> Nav.Key -> ( Model, Cmd Msg ) -init maybeViewer url navKey = - changeRouteTo (Route.fromUrl url) - (Redirect (Session.fromViewer navKey maybeViewer)) +type alias Msg = + Spa.Msg Session.Msg StackMsg -- VIEW -view : Model -> Document Msg -view model = - let - viewer = - Session.viewer (toSession model) - - viewPage page toMsg config = - let - { title, body } = - Page.view viewer page config - in - { title = title - , body = List.map (Html.map toMsg) body - } - in - case model of - Redirect _ -> - Page.view viewer Page.Other Blank.view - - NotFound _ -> - Page.view viewer Page.Other NotFound.view - - Stack session stackmodel -> - let - page = - stack.view session stackmodel - in - viewPage page.page StackMsg { title = page.title, content = page.content } - - - --- UPDATE - - -type Msg - = ChangedUrl Url - | ClickedLink Browser.UrlRequest - | GotSession Session - | StackMsg StackMsg - | SessionMsg Session.Msg - | Noop - - -toSession : Model -> Session -toSession page = - case page of - Redirect session -> - session - - NotFound session -> - session - - Stack session _ -> - session - - -changeRouteTo : Maybe Route -> Model -> ( Model, Cmd Msg ) -changeRouteTo maybeRoute model = - let - session = - toSession model - in - case maybeRoute of - Nothing -> - ( NotFound session, Cmd.none ) - - Just Route.Root -> - ( model, Route.replaceUrl (Session.navKey session) Route.Home ) - - Just Route.Logout -> - ( model, Api.logout ) - - Just route -> - let - ( newStack, effect ) = - case model of - Stack _ stackModel -> - stack.update session (Spa.PageStack.routeChange route) stackModel - - _ -> - stack.init session route - in - ( Stack session newStack, Effect.toCmd ( always Noop, StackMsg ) effect ) - - -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - case ( msg, model ) of - ( ClickedLink urlRequest, _ ) -> - case urlRequest of - Browser.Internal url -> - case url.fragment of - Nothing -> - -- If we got a link that didn't include a fragment, - -- it's from one of those (href "") attributes that - -- we have to include to make the RealWorld CSS work. - -- - -- In an application doing path routing instead of - -- fragment-based routing, this entire - -- `case url.fragment of` expression this comment - -- is inside would be unnecessary. - ( model, Cmd.none ) - - Just _ -> - ( model - , Nav.pushUrl (Session.navKey (toSession model)) (Url.toString url) - ) - - Browser.External href -> - ( model - , Nav.load href - ) - - ( ChangedUrl url, _ ) -> - changeRouteTo (Route.fromUrl url) model - - ( GotSession session, Redirect _ ) -> - ( Redirect session - , Route.replaceUrl (Session.navKey session) Route.Home - ) - - ( StackMsg stackMsg, Stack session stackModel ) -> - stack.update session stackMsg stackModel - |> Tuple.mapFirst (Stack session) - |> Tuple.mapSecond (Effect.toCmd ( always Noop, StackMsg )) - - ( SessionMsg sessionMsg, Stack session stackModel ) -> - let - ( newSession, cmd ) = - Session.update sessionMsg session - in - ( Stack newSession stackModel, Cmd.map SessionMsg cmd ) - - ( _, _ ) -> - -- 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)) - - Stack session stackmodel -> - Sub.batch - [ Sub.map StackMsg (stack.subscriptions session stackmodel) - , Sub.map SessionMsg (Session.subscriptions session) - ] +toDocument : Session -> View Msg -> Browser.Document Msg +toDocument session view = + View.view (Session.viewer session) view -- MAIN -main : Program Value Model Msg main = - Api.application Viewer.decoder - { init = init - , onUrlChange = ChangedUrl - , onUrlRequest = ClickedLink - , subscriptions = subscriptions - , update = update - , view = view + Spa.init + { defaultView = View.default + , extractIdentity = Session.viewer } + |> Spa.addPublicPage ( View.map, View.map ) Route.matchHome Home.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchSettings Settings.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchProfile Profile.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchLogin Login.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchRegister Register.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchArticle Article.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchEditor Editor.page + |> Spa.addPublicPage ( View.map, View.map ) Route.matchLogout Logout.page + |> Spa.application View.map + { init = Session.init + , subscriptions = Session.subscriptions + , update = Session.update + , toRoute = Route.fromUrl >> Maybe.withDefault Route.Home + , toDocument = toDocument + , protectPage = always (Route.toString Route.Home) + } + |> Spa.onUrlRequest Session.ClickedLink + |> Browser.application diff --git a/src/Page.elm b/src/Page.elm index f1790bff6f..e7dba6646c 100644 --- a/src/Page.elm +++ b/src/Page.elm @@ -1,4 +1,4 @@ -module Page exposing (Page(..), view, viewErrors) +module Page exposing (Page(..)) import Api exposing (Cred) import Avatar @@ -28,129 +28,3 @@ type Page | Settings | Profile Username | NewArticle - - -{-| Take a page's Html and frames it with a header and footer. - -The caller provides the current user, so we can display in either -"signed in" (rendering username) or "signed out" mode. - -isLoading is for determining whether we should show a loading spinner -in the header. (This comes up during slow page transitions.) - --} -view : Maybe Viewer -> Page -> { title : String, content : Html msg } -> Document msg -view maybeViewer page { title, content } = - { title = title ++ " - Conduit" - , body = viewHeader page maybeViewer :: content :: [ viewFooter ] - } - - -viewHeader : Page -> Maybe Viewer -> Html msg -viewHeader page maybeViewer = - nav [ class "navbar navbar-light" ] - [ div [ class "container" ] - [ a [ class "navbar-brand", Route.href Route.Home ] - [ text "conduit" ] - , ul [ class "nav navbar-nav pull-xs-right" ] <| - navbarLink page Route.Home [ text "Home" ] - :: viewMenu page maybeViewer - ] - ] - - -viewMenu : Page -> Maybe Viewer -> List (Html msg) -viewMenu page maybeViewer = - let - linkTo = - navbarLink page - in - case maybeViewer of - Just viewer -> - let - username = - Viewer.username viewer - - avatar = - Viewer.avatar viewer - in - [ linkTo Route.NewArticle [ i [ class "ion-compose" ] [], text "\u{00A0}New Post" ] - , linkTo Route.Settings [ i [ class "ion-gear-a" ] [], text "\u{00A0}Settings" ] - , linkTo - (Route.Profile username) - [ img [ class "user-pic", Avatar.src avatar ] [] - , Username.toHtml username - ] - , linkTo Route.Logout [ text "Sign out" ] - ] - - Nothing -> - [ linkTo Route.Login [ text "Sign in" ] - , linkTo Route.Register [ text "Sign up" ] - ] - - -viewFooter : Html msg -viewFooter = - footer [] - [ div [ class "container" ] - [ a [ class "logo-font", href "/" ] [ text "conduit" ] - , span [ class "attribution" ] - [ text "An interactive learning project from " - , a [ href "https://thinkster.io" ] [ text "Thinkster" ] - , text ". Code & design licensed under MIT." - ] - ] - ] - - -navbarLink : Page -> Route -> List (Html msg) -> Html msg -navbarLink page route linkContent = - li [ classList [ ( "nav-item", True ), ( "active", isActive page route ) ] ] - [ a [ class "nav-link", Route.href route ] linkContent ] - - -isActive : Page -> Route -> Bool -isActive page route = - case ( page, route ) of - ( Home, Route.Home ) -> - True - - ( Login, Route.Login ) -> - True - - ( Register, Route.Register ) -> - True - - ( Settings, Route.Settings ) -> - True - - ( Profile pageUsername, Route.Profile routeUsername ) -> - pageUsername == routeUsername - - ( NewArticle, Route.NewArticle ) -> - True - - _ -> - False - - -{-| Render dismissable errors. We use this all over the place! --} -viewErrors : msg -> List String -> Html msg -viewErrors dismissErrors errors = - if List.isEmpty errors then - Html.text "" - - else - div - [ class "error-messages" - , style "position" "fixed" - , style "top" "0" - , style "background" "rgb(250, 250, 250)" - , style "padding" "20px" - , style "border" "1px solid" - ] - <| - List.map (\error -> p [] [ text error ]) errors - ++ [ button [ onClick dismissErrors ] [ text "Ok" ] ] diff --git a/src/Page/Article.elm b/src/Page/Article.elm index 4157563f32..07acf84dc8 100644 --- a/src/Page/Article.elm +++ b/src/Page/Article.elm @@ -142,7 +142,7 @@ view session model = ] ] buttons - , Page.viewErrors ClickedDismissErrors model.errors + , View.viewErrors ClickedDismissErrors model.errors ] ] , div [ class "container page" ] diff --git a/src/Page/Logout.elm b/src/Page/Logout.elm new file mode 100644 index 0000000000..e60802eafa --- /dev/null +++ b/src/Page/Logout.elm @@ -0,0 +1,49 @@ +module Page.Logout exposing (Model, Msg, page) + +import Api +import Effect exposing (Effect) +import Html +import Page +import Session exposing (Session) +import Spa.Page +import View exposing (View) + + +page session = + Spa.Page.element + { init = init + , update = update + , subscriptions = subscriptions + , view = view + } + + +type alias Model = + () + + +type alias Msg = + () + + +init : () -> ( Model, Effect Session.Msg Msg ) +init _ = + ( (), Effect.fromCmd Api.logout ) + + +update : Msg -> Model -> ( Model, Effect Session.Msg Msg ) +update _ model = + ( model, Effect.none ) + + +subscriptions : Model -> Sub Msg +subscriptions _ = + Sub.none + + +view : Model -> View Msg +view _ = + { title = "Logout" + , page = Page.Other + , content = Html.text "Logout in progress" + } diff --git a/src/Page/Profile.elm b/src/Page/Profile.elm index 19cf87bf35..be95f0746a 100644 --- a/src/Page/Profile.elm +++ b/src/Page/Profile.elm @@ -208,7 +208,7 @@ view session model = text "" in div [ class "profile-page" ] - [ Page.viewErrors ClickedDismissErrors model.errors + [ View.viewErrors ClickedDismissErrors model.errors , div [ class "user-info" ] [ div [ class "container" ] [ div [ class "row" ] diff --git a/src/Route.elm b/src/Route.elm index ed9c9b1111..6adad2e59b 100644 --- a/src/Route.elm +++ b/src/Route.elm @@ -1,4 +1,4 @@ -module Route exposing (Route(..), fromUrl, href, matchArticle, matchEditor, matchHome, matchLogin, matchProfile, matchRegister, matchSettings, replaceUrl) +module Route exposing (Route(..), fromUrl, href, matchArticle, matchEditor, matchHome, matchLogin, matchLogout, matchProfile, matchRegister, matchSettings, replaceUrl, toString) import Article.Slug as Slug exposing (Slug) import Browser.Navigation as Nav @@ -65,6 +65,11 @@ fromUrl url = |> Parser.parse parser +toString : Route -> String +toString = + routeToString + + -- INTERNAL @@ -172,3 +177,8 @@ matchEditor route = _ -> Nothing + + +matchLogout : Route -> Maybe () +matchLogout = + matchBasic Logout diff --git a/src/Session.elm b/src/Session.elm index 6299183966..c3d7f0e553 100644 --- a/src/Session.elm +++ b/src/Session.elm @@ -1,7 +1,8 @@ -module Session exposing (Msg, Session, changes, cred, fromViewer, navKey, subscriptions, update, viewer) +module Session exposing (Msg(..), Session, changes, cred, fromViewer, init, navKey, subscriptions, update, viewer) import Api exposing (Cred) import Avatar exposing (Avatar) +import Browser import Browser.Navigation as Nav import Json.Decode as Decode exposing (Decoder) import Json.Decode.Pipeline exposing (custom, required) @@ -9,6 +10,7 @@ import Json.Encode as Encode exposing (Value) import Profile exposing (Profile) import Route import Time +import Url import Viewer exposing (Viewer) @@ -23,6 +25,17 @@ type Session type Msg = GotSession Session + | ClickedLink Browser.UrlRequest + + +init : Value -> Nav.Key -> ( Session, Cmd Msg ) +init flags key = + ( Decode.decodeValue Decode.string flags + |> Result.andThen (Decode.decodeString (Api.storageDecoder Viewer.decoder)) + |> Result.toMaybe + |> fromViewer key + , Cmd.none + ) update : Msg -> Session -> ( Session, Cmd Msg ) @@ -33,6 +46,31 @@ update msg session = , Route.replaceUrl (navKey session) Route.Home ) + 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. + ( session, Cmd.none ) + + Just _ -> + ( session + , Nav.pushUrl (navKey session) (Url.toString url) + ) + + Browser.External href -> + ( session + , Nav.load href + ) + subscriptions : Session -> Sub Msg subscriptions session = diff --git a/src/View.elm b/src/View.elm index c1490e339b..e0ab040743 100644 --- a/src/View.elm +++ b/src/View.elm @@ -1,7 +1,17 @@ module View exposing (..) -import Html exposing (Html) -import Page exposing (Page) +import Api exposing (Cred) +import Avatar +import Browser exposing (Document) +import Html exposing (Html, a, button, div, footer, i, img, li, nav, p, span, text, ul) +import Html.Attributes exposing (class, classList, href, style) +import Html.Events exposing (onClick) +import Page exposing (Page(..)) +import Profile +import Route exposing (Route) +import Session exposing (Session) +import Username exposing (Username) +import Viewer exposing (Viewer) type alias View msg = @@ -12,10 +22,10 @@ type alias View msg = map : (msg -> msg1) -> View msg -> View msg1 -map fn view = - { title = view.title - , page = view.page - , content = Html.map fn view.content +map fn v = + { title = v.title + , page = v.page + , content = Html.map fn v.content } @@ -25,3 +35,129 @@ default = , page = Page.Other , content = Html.text "" } + + +{-| 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 -> View msg -> Document msg +view maybeViewer { title, page, content } = + { title = title ++ " - Conduit" + , body = viewHeader page maybeViewer :: content :: [ viewFooter ] + } + + +viewHeader : Page -> Maybe Viewer -> Html msg +viewHeader page maybeViewer = + nav [ class "navbar navbar-light" ] + [ div [ class "container" ] + [ a [ class "navbar-brand", Route.href Route.Home ] + [ text "conduit" ] + , ul [ class "nav navbar-nav pull-xs-right" ] <| + navbarLink page Route.Home [ text "Home" ] + :: viewMenu page maybeViewer + ] + ] + + +viewMenu : Page -> Maybe Viewer -> List (Html msg) +viewMenu page maybeViewer = + let + linkTo = + navbarLink page + in + case maybeViewer of + Just viewer -> + let + username = + Viewer.username viewer + + avatar = + Viewer.avatar viewer + in + [ linkTo Route.NewArticle [ i [ class "ion-compose" ] [], text "\u{00A0}New Post" ] + , linkTo Route.Settings [ i [ class "ion-gear-a" ] [], text "\u{00A0}Settings" ] + , linkTo + (Route.Profile username) + [ img [ class "user-pic", Avatar.src avatar ] [] + , Username.toHtml username + ] + , linkTo Route.Logout [ text "Sign out" ] + ] + + Nothing -> + [ linkTo Route.Login [ text "Sign in" ] + , linkTo Route.Register [ text "Sign up" ] + ] + + +viewFooter : Html msg +viewFooter = + footer [] + [ div [ class "container" ] + [ a [ class "logo-font", href "/" ] [ text "conduit" ] + , span [ class "attribution" ] + [ text "An interactive learning project from " + , a [ href "https://thinkster.io" ] [ text "Thinkster" ] + , text ". Code & design licensed under MIT." + ] + ] + ] + + +navbarLink : Page -> Route -> List (Html msg) -> Html msg +navbarLink page route linkContent = + li [ classList [ ( "nav-item", True ), ( "active", isActive page route ) ] ] + [ a [ class "nav-link", Route.href route ] linkContent ] + + +isActive : Page -> Route -> Bool +isActive page route = + case ( page, route ) of + ( Home, Route.Home ) -> + True + + ( Login, Route.Login ) -> + True + + ( Register, Route.Register ) -> + True + + ( Settings, Route.Settings ) -> + True + + ( Profile pageUsername, Route.Profile routeUsername ) -> + pageUsername == routeUsername + + ( NewArticle, Route.NewArticle ) -> + True + + _ -> + False + + +{-| Render dismissable errors. We use this all over the place! +-} +viewErrors : msg -> List String -> Html msg +viewErrors dismissErrors errors = + if List.isEmpty errors then + Html.text "" + + else + div + [ class "error-messages" + , style "position" "fixed" + , style "top" "0" + , style "background" "rgb(250, 250, 250)" + , style "padding" "20px" + , style "border" "1px solid" + ] + <| + List.map (\error -> p [] [ text error ]) errors + ++ [ button [ onClick dismissErrors ] [ text "Ok" ] ]