diff --git a/.gitignore b/.gitignore index 4bc8535..549fed8 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,4 @@ -elm-stuff +/build +/elm-stuff +/node_modules +/app.js diff --git a/Main.elm b/Main.elm new file mode 100644 index 0000000..9b1febb --- /dev/null +++ b/Main.elm @@ -0,0 +1,322 @@ +module Main exposing (..) + +import Json.Encode as Encode +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (..) +import HtmlParser +import HtmlParser.Util exposing (textContent) +import Navigation +import Ports +import Mastodon + + +type alias Flags = + { client : Maybe Mastodon.Client + , registration : Maybe Mastodon.AppRegistration + } + + +type Msg + = AccessToken (Result Mastodon.Error Mastodon.AccessTokenResult) + | AppRegistered (Result Mastodon.Error Mastodon.AppRegistration) + | LocalTimeline (Result Mastodon.Error (List Mastodon.Status)) + | PublicTimeline (Result Mastodon.Error (List Mastodon.Status)) + | Register + | ServerChange String + | UrlChange Navigation.Location + | UserTimeline (Result Mastodon.Error (List Mastodon.Status)) + + +type alias Model = + { server : String + , registration : Maybe Mastodon.AppRegistration + , client : Maybe Mastodon.Client + , userTimeline : List Mastodon.Status + , localTimeline : List Mastodon.Status + , publicTimeline : List Mastodon.Status + , errors : List String + , location : Navigation.Location + } + + +extractAuthCode : Navigation.Location -> Maybe String +extractAuthCode { search } = + case (String.split "?code=" search) of + [ _, authCode ] -> + Just authCode + + _ -> + Nothing + + +init : Flags -> Navigation.Location -> ( Model, Cmd Msg ) +init flags location = + let + authCode = + extractAuthCode location + in + { server = "" + , registration = flags.registration + , client = flags.client + , userTimeline = [] + , localTimeline = [] + , publicTimeline = [] + , errors = [] + , location = location + } + ! [ initCommands flags.registration flags.client authCode ] + + +initCommands : Maybe Mastodon.AppRegistration -> Maybe Mastodon.Client -> Maybe String -> Cmd Msg +initCommands registration client authCode = + Cmd.batch <| + case authCode of + Just authCode -> + case registration of + Just registration -> + [ Mastodon.getAccessToken registration authCode |> Mastodon.send AccessToken ] + + Nothing -> + [] + + Nothing -> + case client of + Just client -> + [ loadTimelines client ] + + Nothing -> + [] + + +registerApp : Model -> Cmd Msg +registerApp { server, location } = + let + appUrl = + location.origin ++ location.pathname + in + Mastodon.register + server + "tooty" + appUrl + "read write follow" + |> Mastodon.send AppRegistered + + +saveClient : Mastodon.Client -> Cmd Msg +saveClient client = + Mastodon.clientEncoder client + |> Encode.encode 0 + |> Ports.saveClient + + +saveRegistration : Mastodon.AppRegistration -> Cmd Msg +saveRegistration registration = + Mastodon.registrationEncoder registration + |> Encode.encode 0 + |> Ports.saveRegistration + + +loadTimelines : Mastodon.Client -> Cmd Msg +loadTimelines client = + Cmd.batch + [ Mastodon.fetchUserTimeline client |> Mastodon.send UserTimeline + , Mastodon.fetchLocalTimeline client |> Mastodon.send LocalTimeline + , Mastodon.fetchPublicTimeline client |> Mastodon.send PublicTimeline + ] + + +errorText : Mastodon.Error -> String +errorText error = + case error of + Mastodon.MastodonError statusCode statusMsg errorMsg -> + "HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg + + Mastodon.ServerError statusCode statusMsg errorMsg -> + "HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg + + Mastodon.TimeoutError -> + "Request timed out." + + Mastodon.NetworkError -> + "Unreachable host." + + +update : Msg -> Model -> ( Model, Cmd Msg ) +update msg model = + case msg of + ServerChange server -> + { model | server = server } ! [] + + UrlChange location -> + model ! [] + + Register -> + model ! [ registerApp model ] + + AppRegistered result -> + case result of + Ok registration -> + { model | registration = Just registration } + ! [ saveRegistration registration + , Navigation.load <| Mastodon.getAuthorizationUrl registration + ] + + Err error -> + { model | errors = (errorText error) :: model.errors } ! [] + + AccessToken result -> + case result of + Ok { server, accessToken } -> + let + client = + Mastodon.Client server accessToken + in + { model | client = Just client } + ! [ loadTimelines client + , Navigation.modifyUrl model.location.pathname + , saveClient client + ] + + Err error -> + { model | errors = (errorText error) :: model.errors } ! [] + + UserTimeline result -> + case result of + Ok userTimeline -> + { model | userTimeline = userTimeline } ! [] + + Err error -> + { model | userTimeline = [], errors = (errorText error) :: model.errors } ! [] + + LocalTimeline result -> + case result of + Ok localTimeline -> + { model | localTimeline = localTimeline } ! [] + + Err error -> + { model | localTimeline = [], errors = (errorText error) :: model.errors } ! [] + + PublicTimeline result -> + case result of + Ok publicTimeline -> + { model | publicTimeline = publicTimeline } ! [] + + Err error -> + { model | publicTimeline = [], errors = (errorText error) :: model.errors } ! [] + + +errorView : String -> Html Msg +errorView error = + div [ class "alert alert-danger" ] [ text error ] + + +errorsListView : Model -> Html Msg +errorsListView model = + case model.errors of + [] -> + text "" + + errors -> + div [] <| List.map errorView model.errors + + +statusView : Mastodon.Status -> Html Msg +statusView status = + case status.reblog of + Just (Mastodon.Reblog reblog) -> + div [ class "reblog" ] + [ p [] + [ a [ href status.account.url ] [ text <| "@" ++ status.account.username ] + , text " reblogged" + ] + , statusView reblog + ] + + Nothing -> + div [ class "status" ] + [ img [ class "avatar", src status.account.avatar ] [] + , div [ class "username" ] [ text status.account.username ] + , div [ class "status-text" ] + [ HtmlParser.parse status.content |> textContent |> text ] + ] + + +timelineView : List Mastodon.Status -> String -> Html Msg +timelineView statuses label = + div [ class "col-sm-4" ] + [ div [ class "panel panel-default" ] + [ div [ class "panel-heading" ] [ text label ] + , ul [ class "list-group" ] <| + List.map + (\s -> + li [ class "list-group-item status" ] + [ statusView s ] + ) + statuses + ] + ] + + +homepageView : Model -> Html Msg +homepageView model = + div [ class "row" ] + [ timelineView model.userTimeline "Home timeline" + , timelineView model.localTimeline "Local timeline" + , timelineView model.publicTimeline "Public timeline" + ] + + +authView : Model -> Html Msg +authView model = + div [ class "col-md-4 col-md-offset-4" ] + [ div [ class "panel panel-default" ] + [ div [ class "panel-heading" ] [ text "Authenticate" ] + , div [ class "panel-body" ] + [ Html.form [ class "form", onSubmit Register ] + [ div [ class "form-group" ] + [ label [ for "server" ] [ text "Mastodon server root URL" ] + , input + [ type_ "url" + , class "form-control" + , id "server" + , required True + , placeholder "https://mastodon.social" + , value model.server + , pattern "https://.+" + , onInput ServerChange + ] + [] + , p [ class "help-block" ] + [ text "You'll be redirected to that server to authenticate yourself. We don't have access to your password." ] + ] + , button [ class "btn btn-primary", type_ "submit" ] + [ text "Sign into Tooty" ] + ] + ] + ] + ] + + +view : Model -> Html Msg +view model = + div [ class "container-fluid" ] + [ h1 [] [ text "tooty" ] + , errorsListView model + , case model.client of + Just client -> + homepageView model + + Nothing -> + authView model + ] + + +main : Program Flags Model Msg +main = + Navigation.programWithFlags UrlChange + { init = init + , view = view + , update = update + , subscriptions = always Sub.none + } diff --git a/Mastodon.elm b/Mastodon.elm new file mode 100644 index 0000000..0d00821 --- /dev/null +++ b/Mastodon.elm @@ -0,0 +1,411 @@ +module Mastodon + exposing + ( AccessTokenResult + , Account + , AppRegistration + , Attachment + , Client + , Error(..) + , Mention + , Reblog(..) + , Status + , Tag + , register + , registrationEncoder + , clientEncoder + , getAuthorizationUrl + , getAccessToken + , fetchPublicTimeline + , fetchLocalTimeline + , fetchUserTimeline + , send + ) + +import Http +import HttpBuilder +import Json.Decode.Pipeline as Pipe +import Json.Decode as Decode +import Json.Encode as Encode + + +-- Types + + +type alias Server = + String + + +type alias AuthCode = + String + + +type alias ClientId = + String + + +type alias ClientSecret = + String + + +type alias StatusCode = + Int + + +type alias StatusMsg = + String + + +type alias Token = + String + + +type alias Client = + { server : Server + , token : Token + } + + +type Error + = MastodonError StatusCode StatusMsg String + | ServerError StatusCode StatusMsg String + | TimeoutError + | NetworkError + + +type alias AppRegistration = + { server : Server + , scope : String + , client_id : ClientId + , client_secret : ClientSecret + , id : Int + , redirect_uri : String + } + + +type alias Account = + { acct : String + , avatar : String + , created_at : String + , display_name : String + , followers_count : Int + , following_count : Int + , header : String + , id : Int + , locked : Bool + , note : String + , statuses_count : Int + , url : String + , username : String + } + + +type alias Attachment = + { id : Int + , -- Type: "image", "video", "gifv" + type_ : String + , url : String + , remote_url : String + , preview_url : String + , text_url : Maybe String + } + + +type alias Mention = + { id : Int + , url : String + , username : String + , acct : String + } + + +type alias Tag = + { name : String + , url : String + } + + +type alias Status = + { account : Account + , content : String + , created_at : String + , favourited : Maybe Bool + , favourites_count : Int + , id : Int + , in_reply_to_account_id : Maybe Int + , in_reply_to_id : Maybe Int + , media_attachments : List Attachment + , mentions : List Mention + , reblog : Maybe Reblog + , reblogged : Maybe Bool + , reblogs_count : Int + , sensitive : Maybe Bool + , spoiler_text : String + , tags : List Tag + , uri : String + , url : String + , visibility : String + } + + +type Reblog + = Reblog Status + + + +-- Msg + + +type StatusListResult + = Result Http.Error (List Status) + + +type alias AccessTokenResult = + { server : Server + , accessToken : Token + } + + + +-- Encoders + + +appRegistrationEncoder : String -> String -> String -> Encode.Value +appRegistrationEncoder client_name redirect_uris scope = + Encode.object + [ ( "client_name", Encode.string client_name ) + , ( "redirect_uris", Encode.string redirect_uris ) + , ( "scopes", Encode.string scope ) + ] + + +authorizationCodeEncoder : AppRegistration -> AuthCode -> Encode.Value +authorizationCodeEncoder registration authCode = + Encode.object + [ ( "client_id", Encode.string registration.client_id ) + , ( "client_secret", Encode.string registration.client_secret ) + , ( "grant_type", Encode.string "authorization_code" ) + , ( "redirect_uri", Encode.string registration.redirect_uri ) + , ( "code", Encode.string authCode ) + ] + + + +-- Decoders + + +appRegistrationDecoder : Server -> String -> Decode.Decoder AppRegistration +appRegistrationDecoder server scope = + Pipe.decode AppRegistration + |> Pipe.hardcoded server + |> Pipe.hardcoded scope + |> Pipe.required "client_id" Decode.string + |> Pipe.required "client_secret" Decode.string + |> Pipe.required "id" Decode.int + |> Pipe.required "redirect_uri" Decode.string + + +accessTokenDecoder : AppRegistration -> Decode.Decoder AccessTokenResult +accessTokenDecoder registration = + Pipe.decode AccessTokenResult + |> Pipe.hardcoded registration.server + |> Pipe.required "access_token" Decode.string + + +accountDecoder : Decode.Decoder Account +accountDecoder = + Pipe.decode Account + |> Pipe.required "acct" Decode.string + |> Pipe.required "avatar" Decode.string + |> Pipe.required "created_at" Decode.string + |> Pipe.required "display_name" Decode.string + |> Pipe.required "followers_count" Decode.int + |> Pipe.required "following_count" Decode.int + |> Pipe.required "header" Decode.string + |> Pipe.required "id" Decode.int + |> Pipe.required "locked" Decode.bool + |> Pipe.required "note" Decode.string + |> Pipe.required "statuses_count" Decode.int + |> Pipe.required "url" Decode.string + |> Pipe.required "username" Decode.string + + +attachmentDecoder : Decode.Decoder Attachment +attachmentDecoder = + Pipe.decode Attachment + |> Pipe.required "id" Decode.int + |> Pipe.required "type" Decode.string + |> Pipe.required "url" Decode.string + |> Pipe.required "remote_url" Decode.string + |> Pipe.required "preview_url" Decode.string + |> Pipe.required "text_url" (Decode.nullable Decode.string) + + +mentionDecoder : Decode.Decoder Mention +mentionDecoder = + Pipe.decode Mention + |> Pipe.required "id" Decode.int + |> Pipe.required "url" Decode.string + |> Pipe.required "username" Decode.string + |> Pipe.required "acct" Decode.string + + +tagDecoder : Decode.Decoder Tag +tagDecoder = + Pipe.decode Tag + |> Pipe.required "name" Decode.string + |> Pipe.required "url" Decode.string + + +reblogDecoder : Decode.Decoder Reblog +reblogDecoder = + Decode.map Reblog (Decode.lazy (\_ -> statusDecoder)) + + +statusDecoder : Decode.Decoder Status +statusDecoder = + Pipe.decode Status + |> Pipe.required "account" accountDecoder + |> Pipe.required "content" Decode.string + |> Pipe.required "created_at" Decode.string + |> Pipe.optional "favourited" (Decode.nullable Decode.bool) Nothing + |> Pipe.required "favourites_count" Decode.int + |> Pipe.required "id" Decode.int + |> Pipe.required "in_reply_to_account_id" (Decode.nullable Decode.int) + |> Pipe.required "in_reply_to_id" (Decode.nullable Decode.int) + |> Pipe.required "media_attachments" (Decode.list attachmentDecoder) + |> Pipe.required "mentions" (Decode.list mentionDecoder) + |> Pipe.optional "reblog" (Decode.nullable reblogDecoder) Nothing + |> Pipe.optional "reblogged" (Decode.nullable Decode.bool) Nothing + |> Pipe.required "reblogs_count" Decode.int + |> Pipe.required "sensitive" (Decode.nullable Decode.bool) + |> Pipe.required "spoiler_text" Decode.string + |> Pipe.required "tags" (Decode.list tagDecoder) + |> Pipe.required "uri" Decode.string + |> Pipe.required "url" Decode.string + |> Pipe.required "visibility" Decode.string + + + +-- Internal helpers + + +encodeUrl : String -> List ( String, String ) -> String +encodeUrl base params = + List.map (\( k, v ) -> k ++ "=" ++ Http.encodeUri v) params + |> String.join "&" + |> (++) (base ++ "?") + + +mastodonErrorDecoder : Decode.Decoder String +mastodonErrorDecoder = + Decode.field "error" Decode.string + + +extractMastodonError : StatusCode -> StatusMsg -> String -> Error +extractMastodonError statusCode statusMsg body = + case Decode.decodeString mastodonErrorDecoder body of + Ok errRecord -> + MastodonError statusCode statusMsg errRecord + + Err err -> + ServerError statusCode statusMsg err + + +extractError : Http.Error -> Error +extractError error = + case error of + Http.BadStatus { status, body } -> + extractMastodonError status.code status.message body + + Http.BadPayload str { status } -> + ServerError + status.code + status.message + ("Failed decoding JSON: " ++ str) + + Http.Timeout -> + TimeoutError + + _ -> + NetworkError + + +toResponse : Result Http.Error a -> Result Error a +toResponse result = + Result.mapError extractError result + + +fetchStatusList : Client -> String -> HttpBuilder.RequestBuilder (List Status) +fetchStatusList client endpoint = + HttpBuilder.get (client.server ++ endpoint) + |> HttpBuilder.withHeader "Authorization" ("Bearer " ++ client.token) + |> HttpBuilder.withExpect (Http.expectJson (Decode.list statusDecoder)) + + + +-- Public API + + +clientEncoder : Client -> Encode.Value +clientEncoder client = + Encode.object + [ ( "server", Encode.string client.server ) + , ( "token", Encode.string client.token ) + ] + + +registrationEncoder : AppRegistration -> Encode.Value +registrationEncoder registration = + Encode.object + [ ( "server", Encode.string registration.server ) + , ( "scope", Encode.string registration.scope ) + , ( "client_id", Encode.string registration.client_id ) + , ( "client_secret", Encode.string registration.client_secret ) + , ( "id", Encode.int registration.id ) + , ( "redirect_uri", Encode.string registration.redirect_uri ) + ] + + +register : Server -> String -> String -> String -> HttpBuilder.RequestBuilder AppRegistration +register server client_name redirect_uri scope = + HttpBuilder.post (server ++ "/api/v1/apps") + |> HttpBuilder.withExpect (Http.expectJson (appRegistrationDecoder server scope)) + |> HttpBuilder.withJsonBody (appRegistrationEncoder client_name redirect_uri scope) + + +getAuthorizationUrl : AppRegistration -> String +getAuthorizationUrl registration = + encodeUrl (registration.server ++ "/oauth/authorize") + [ ( "response_type", "code" ) + , ( "client_id", registration.client_id ) + , ( "scope", registration.scope ) + , ( "redirect_uri", registration.redirect_uri ) + ] + + +getAccessToken : AppRegistration -> AuthCode -> HttpBuilder.RequestBuilder AccessTokenResult +getAccessToken registration authCode = + HttpBuilder.post (registration.server ++ "/oauth/token") + |> HttpBuilder.withExpect (Http.expectJson (accessTokenDecoder registration)) + |> HttpBuilder.withJsonBody (authorizationCodeEncoder registration authCode) + + +send : (Result Error a -> msg) -> HttpBuilder.RequestBuilder a -> Cmd msg +send tagger builder = + builder + |> HttpBuilder.send (toResponse >> tagger) + + +fetchUserTimeline : Client -> HttpBuilder.RequestBuilder (List Status) +fetchUserTimeline client = + fetchStatusList client "/api/v1/timelines/home" + + +fetchLocalTimeline : Client -> HttpBuilder.RequestBuilder (List Status) +fetchLocalTimeline client = + fetchStatusList client "/api/v1/timelines/public?local=true" + + +fetchPublicTimeline : Client -> HttpBuilder.RequestBuilder (List Status) +fetchPublicTimeline client = + fetchStatusList client "/api/v1/timelines/public" diff --git a/Ports.elm b/Ports.elm new file mode 100644 index 0000000..7e7858f --- /dev/null +++ b/Ports.elm @@ -0,0 +1,7 @@ +port module Ports exposing (saveRegistration, saveClient) + + +port saveRegistration : String -> Cmd msg + + +port saveClient : String -> Cmd msg diff --git a/README.md b/README.md index 303745c..20d0d35 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,27 @@ # tooty -A Mastodon client written in Elm. +An [experimental Mastodon client](https://n1k0.github.io/tooty/) written in Elm. It is not usable yet. + +![](http://i.imgur.com/nR843q3.png) + +### Setting up the development environment + + $ npm i + +### Starting the dev server + + $ npm run live + +### Building + + $ npm run build + +### Deploying to gh-pages + + $ npm run deploy + +The app should be deployed to https://n1k0.github.io/tooty/ + +## Licence + +MIT diff --git a/elm-package.json b/elm-package.json index 3b2df07..1fa0161 100644 --- a/elm-package.json +++ b/elm-package.json @@ -8,8 +8,14 @@ ], "exposed-modules": [], "dependencies": { + "NoRedInk/elm-decode-pipeline": "3.0.0 <= v < 4.0.0", "elm-lang/core": "5.1.1 <= v < 6.0.0", - "elm-lang/html": "2.0.0 <= v < 3.0.0" + "elm-lang/html": "2.0.0 <= v < 3.0.0", + "elm-lang/http": "1.0.0 <= v < 2.0.0", + "elm-lang/navigation": "2.1.0 <= v < 3.0.0", + "evancz/url-parser": "2.0.1 <= v < 3.0.0", + "jinjor/elm-html-parser": "1.1.4 <= v < 2.0.0", + "lukewestby/elm-http-builder": "5.1.0 <= v < 6.0.0" }, "elm-version": "0.18.0 <= v < 0.19.0" } diff --git a/index.html b/index.html new file mode 100644 index 0000000..dd33eee --- /dev/null +++ b/index.html @@ -0,0 +1,26 @@ + + +
+ +