Token HTTP Authentication in Elm

.gitignore

elm-stuff/

elm-package.json

{
    "version": "1.0.0",
    "summary": "helpful summary of your project, less than 80 characters",
    "repository": "https://github.com/user/project.git",
    "license": "BSD3",
    "source-directories": [
        "."
    ],
    "exposed-modules": [],
    "dependencies": {
        "Fresheyeball/elm-tuple-extra": "2.1.0 <= v < 3.0.0",
        "elm-community/list-extra": "2.0.0 <= v < 3.0.0",
        "elm-lang/core": "4.0.1 <= v < 5.0.0",
        "elm-lang/html": "1.0.0 <= v < 2.0.0",
        "evancz/elm-http": "3.0.1 <= v < 4.0.0"
    },
    "elm-version": "0.17.0 <= v < 0.18.0"
}

Main.elm

module Main exposing (..)

import Char
import Html as H exposing (Html)
import Html.App as App
import Html.Events as HE
import Http
import Json.Decode as Json exposing ((:=))
import List.Extra as List
import Random exposing (Generator)
import String
import Task exposing (Task)
import Tuple2
import TokenRetry


main : Program Never
main =
    App.program
        { init = init
        , update = update
        , view = view
        , subscriptions = always Sub.none
        }



-- MODEL


type alias Model =
    { tokenHandler : TokenRetry.Model Msg
    , errors : List Http.Error
    , ip : String
    }


type Token
    = Good String
    | Bad String
    | None


init : ( Model, Cmd Msg )
init =
    let
        model =
            Model (TokenRetry.new fetchToken RetryMsg) [] ""
    in
        model ! [ TokenRetry.initCmd model.tokenHandler ]



-- UPDATE


type Msg
    = GotIP String
    | FetchIP
    | RetryMsg (TokenRetry.Msg Msg)
    | Error Http.Error


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg |> Debug.log "msg" of
        RetryMsg msg ->
            model.tokenHandler
                |> TokenRetry.update msg
                |> Tuple2.mapFst (\tokenHandler -> { model | tokenHandler = tokenHandler })

        FetchIP ->
            TokenRetry.Request fetchIP Error
                |> TokenRetry.send model.tokenHandler
                |> (,) model

        GotIP ip ->
            { model | ip = ip } ! []

        Error err ->
            { model | errors = err :: model.errors } ! []



-- VIEW


view : Model -> Html Msg
view model =
    H.div []
        [ H.button [ HE.onClick FetchIP ] [ H.text "send request" ]
        , H.text model.ip
        , errorList model.errors
        ]


errorList : List Http.Error -> Html msg
errorList errors =
    errors
        |> List.map (H.li [] << List.singleton << H.text << toString)
        |> H.ol []



-- HTTP API


fetchIP : String -> Task Http.Error Msg
fetchIP token =
    Http.url "http://ip-api.com/json" [ (,) "token" token ]
        |> Http.get ("query" := Json.string)
        |> Task.map (Debug.log "got IP" >> GotIP)


fetchToken : Cmd String
fetchToken =
    Random.generate identity tokenGenerator


tokenGenerator : Generator String
tokenGenerator =
    let
        merge one other =
            Random.andThen Random.bool
                (\cond ->
                    if cond then
                        one
                    else
                        other
                )

        upLetter =
            Random.int 65 90
                |> Random.map Char.fromCode

        digit =
            Random.int 48 57
                |> Random.map Char.fromCode
    in
        (upLetter `merge` digit)
            |> Random.list 20
            |> Random.map (List.foldl String.cons "")

TokenRetry.elm

module TokenRetry exposing (Model, Request, Msg, new, initCmd, update, send)

import Http
import Task exposing (Task)
import Time


new : Cmd String -> (Msg msg -> msg) -> Model msg
new fetchToken wrapMsg =
    Model None [] (Cmd.map GotToken fetchToken) wrapMsg


initCmd : Model msg -> Cmd msg
initCmd model =
    model.fetchToken |> Cmd.map model.wrapMsg


send : Model msg -> Request msg -> Cmd msg
send model request =
    request
        |> IssueRequest
        |> model.wrapMsg
        |> \msg ->
            Time.now
                |> Task.perform (\_ -> Debug.crash "never") (always msg)



-- MODEL


type alias Model msg =
    { token : Token
    , requests : List (Request msg)
    , fetchToken : Cmd (Msg msg)
    , wrapMsg : Msg msg -> msg
    }


type alias Request msg =
    { run : String -> Task Http.Error msg
    , onError : Http.Error -> msg
    }


type Token
    = Good String
    | Bad String
    | None



-- UPDATE


type Msg msg
    = GotToken String
    | FetchToken
    | IssueRequest (Request msg)
    | Error (Request msg) msg


update : Msg msg -> Model msg -> ( Model msg, Cmd msg )
update msg model =
    case msg of
        GotToken token ->
            model.requests
                |> List.map (requestToCommand model token)
                |> (!) { model | token = Good token, requests = [] }

        FetchToken ->
            model.fetchToken
                |> Cmd.map model.wrapMsg
                |> (,) model

        IssueRequest request ->
            model
                |> issueRequest request

        Error request msg ->
            let
                ( model', cmds ) =
                    markTokenAsBad model

                ( model'', cmds' ) =
                    model' |> issueRequest request
            in
                model'' ! [ cmds, cmds' ]


issueRequest : Request msg -> Model msg -> ( Model msg, Cmd msg )
issueRequest request model =
    case model.token of
        Bad _ ->
            { model | requests = request :: model.requests } ! []

        Good token ->
            requestToCommand model token request
                |> (,) model

        None ->
            model.fetchToken
                |> Cmd.map model.wrapMsg
                |> (,) { model | requests = request :: model.requests }


requestToCommand : Model msg -> String -> Request msg -> Cmd msg
requestToCommand model token ({ run, onError } as request) =
    token
        |> run
        |> Task.perform (handleError model request onError) identity


handleError : Model msg -> Request msg -> (Http.Error -> msg) -> Http.Error -> msg
handleError model request onError err =
    onError err
        |> Error request
        |> model.wrapMsg


markTokenAsBad : Model msg -> ( Model msg, Cmd msg )
markTokenAsBad model =
    let
        newModel =
            case model.token of
                Good token ->
                    { model | token = Bad token }

                _ ->
                    model
    in
        model.fetchToken
            |> Cmd.map model.wrapMsg
            |> (,) newModel