Skip to content

Instantly share code, notes, and snippets.

@gampleman

gampleman/Main.elm

Last active February 22, 2021 12:41
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
  • Save gampleman/db87708f80953435a6e1aa0bbfee086d to your computer and use it in GitHub Desktop.
Save gampleman/db87708f80953435a6e1aa0bbfee086d to your computer and use it in GitHub Desktop.
Download ZIP
URL Coders
Raw
README.md

URLs exist as a lossy serialization of application state. We have a good solution in Elm for serialization: Codecs.

However, URLs are lossy. I mean by this that there are 4 types of information in the Model:

  1. Environmental state: This is stuff like the currently logged in user, the viewport size, or the current date. These should not be persisted in the URL and there should be appropriate initialization logic to get these values.
  2. Incidental state: This is stuff that could be in the URL, but we choose not to. For example things like which accordion tab is open, or which animation is playing. Again, there shouuld be appropriate initialization logic, but this is usually simpler as it will usually just be a "default" value.
  3. Shared state: This is state that is shared between the client and the server and is persisted on the server. The client usually has some sort of ID by which it can refer to this server side state and fetches the state from the server as appropriate. The serialization of this state then is simply to extract this ID and serialize that. The desiarilaztion involves fetching the resource from the server (this can lead to additional complexity where loading state may need to be introduced into the application).
  4. Other state: Any other state should be directly serialized into the URL.

However, URL serialization has some complexities that make it quite gnarly:

  1. URLs should be human readable: URLs are for better or worse part of the user visible part of the product. It is desirable if the URLs are understandable for humans reading them.

  2. URLs are flat: Typical URL formats don't have established ways for nesting information (especially not deeply. You can probably get away with ?user[name]=John&user[email]=john@acme.com, but ?users[][name][first]=John starts to get very unreadable.)

  3. URLs practically have a max length: While the spec doesn't impose one, to ensure maximum interoperability there are practical limits imposed by implementations. The current maximum limit seems to be 1745 characters (excluding the domain part, which your Elm app probably doesn't particularly care about anyway).

  4. There are 3 different kinds of ways information can be serialized:

    • As path segements: /foo/bar/baz. These are essentially like positional arguments in the sense that they don't expose any key value structure, but can be interpreted hierachically (i.e. bar/baz can have different meaning if preceeded by /foo/ than if preceeded by /qux/).
    • Hash: #frefr, this is typically a simple string, although also typically segments as above can be implemented here.
    • Query params: ?foo=bar&baz=qux. These are essentially key value pairs, in the sense that order does typically not matter.

    However, these are kind of independent.

Finally, one last bit of complexity here is history management:

  1. When the client app changes the URL, it can choose to insert a new history entry (essentially allowing you to press "back" in your browser) or replace the current history entry (meaning your history doesn't get filled up with meaningless changes). Generally picking which one to use is an excersise in distuingishing things where the user might want to get back to and can't quite be done automatically.
  2. Browsers may rate-limit this function by throwing an exception. The discussion here suggests that the limit is 100 calls per 30 second interval in Safari in 2016. It also suggests techniques for people changing the URL based on scroll position.

As such we want a structure that can map a model to a URL, and map a URL back to a Flags -> (Model, Cmd Msg) initialization function.

This library implements an API that can build such a structure without a huge fuss:

router : Router () Model
router =
    URLCoders.custom
        (\index detail value ->
            case value of
                Index data ->
                    index data

                Detail post comments ->
                    detail ( post, comments )
        )
        |> URLCoders.variant1 "index" Index indexRouter
        |> URLCoders.variant1 "detail" (\( post, comms ) -> Detail post comms) detailRouter
        |> URLCoders.buildCustom


indexRouter : Router () IndexDetails
indexRouter =
    URLCoders.partial .search
        (\_ query ->
            filterPosts query
                |> Task.map (\posts -> { search = query, posts = Loaded posts })
        )
        URLCoders.string


detailRouter : Router () ( Post, Remote (List Comment) )
detailRouter =
    URLCoders.partial (Tuple.first >> .id)
        (\_ id ->
            Task.map2 Tuple.pair (getPost id) (getComments id |> Task.map Loaded)
                |> Task.mapError (always URLCoders.RoutingError)
        )
        URLCoders.int
        |> URLCoders.pushUrlOnChange -- ensure changes get added to the history
Raw
Main.elm
module Main exposing (main)
{-| This is the demo of how this looks in a super simple blog.
This is paradoxical, since I don't really consider a blog to be the thing
you should build as a SPA, since it clearly has multiple pages.
But as a stretch it works.
-}
import Html exposing (Html)
import Html.Attributes
import Html.Events
import Process
import Task exposing (Task)
import URLCoders exposing (Remote(..), Router)
-- entrypoint
main =
URLCoders.application
{ view = view
, update = update
, subscriptions = \_ -> Sub.none
, router = router
}
-- Model
type Model
= Index IndexDetails
| Detail Post (Remote (List Comment))
type alias IndexDetails =
{ posts : Remote (List Post), search : String }
type alias Post =
{ id : Int
, title : String
, body : String
}
type alias Comment =
{ user : String
, body : String
}
-- Msg
type Msg
= Open Post
| Search String
| LoadedComments (List Comment)
| LoadedPosts (List Post)
-- Update
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
Open post ->
( Detail post Loading, Task.perform LoadedComments (getComments post.id) )
LoadedComments comments ->
case model of
Detail post _ ->
( Detail post (Loaded comments), Cmd.none )
_ ->
( model, Cmd.none )
LoadedPosts posts ->
case model of
Index sub ->
( Index { sub | posts = Loaded posts }, Cmd.none )
_ ->
( model, Cmd.none )
Search query ->
case model of
Index sub ->
( Index { sub | search = query, posts = Loading }, Task.perform LoadedPosts (filterPosts query) )
_ ->
( model, Cmd.none )
-- Router
router : Router () Model
router =
URLCoders.custom
(\index detail value ->
case value of
Index data ->
index data
Detail post comments ->
detail ( post, comments )
)
|> URLCoders.variant1 "index" Index indexRouter
|> URLCoders.variant1 "detail" (\( post, comms ) -> Detail post comms) detailRouter
|> URLCoders.buildCustom
indexRouter : Router () IndexDetails
indexRouter =
URLCoders.partial .search
(\_ query ->
filterPosts query
|> Task.map (\posts -> { search = query, posts = Loaded posts })
)
URLCoders.string
detailRouter : Router () ( Post, Remote (List Comment) )
detailRouter =
URLCoders.partial (Tuple.first >> .id)
(\_ id ->
Task.map2 Tuple.pair (getPost id) (getComments id |> Task.map Loaded)
|> Task.mapError (always URLCoders.RoutingError)
)
URLCoders.int
|> URLCoders.pushUrlOnChange
-- Views
view model =
{ title = "My Special Blog"
, body =
[ case model of
Index { posts, search } ->
viewRemote
(\p ->
p
|> List.map viewPostPreview
|> Html.div []
)
posts
Detail post remoteComments ->
Html.div []
[ viewPost post
, viewRemote viewComments remoteComments
]
]
}
viewRemote : (a -> Html Msg) -> Remote a -> Html Msg
viewRemote subView remote =
case remote of
Loaded data ->
subView data
Loading ->
Html.text "loading..."
Error ->
Html.text "Something went wrong loading..."
viewPostPreview : Post -> Html Msg
viewPostPreview post =
Html.h2 []
[ Html.a [ Html.Events.onClick (Open post), Html.Attributes.href "#" ]
[ Html.text post.title
]
]
viewPost : Post -> Html Msg
viewPost post =
Html.article []
[ Html.h1 []
[ Html.text post.title
]
, Html.p [] [ Html.text post.body ]
]
viewComments : List Comment -> Html Msg
viewComments comments =
comments
|> List.map
(\comment ->
Html.div []
[ Html.strong [] [ Html.text comment.user ]
, Html.p [] [ Html.text comment.body ]
]
)
|> Html.div []
-- Fake backend
-- These functions would normally be HTTP based tasks
{-| Like Task.succeed, but bakes in a bit of delay to look like a backend request.
-}
eventually : a -> Task x a
eventually value =
Process.sleep 1200
|> Task.map (always value)
allPosts : List ( Int, String, Int )
allPosts =
[ ( 1, "First posts", 0 )
, ( 2, "About the crazy goings in Tobago", 3 )
, ( 3, "A total snoozefest", 1 )
, ( 4, "Madness? This is Spartaaaaaa!", 23 )
, ( 5, "Elm is great...", 2 )
, ( 6, "...Routing not so much", 12 )
, ( 7, "My favourite spy films of all time", 2 )
]
filterPosts : String -> Task x (List Post)
filterPosts query =
allPosts
|> List.filterMap
(\( id, title, _ ) ->
if String.contains query title then
Just { id = id, title = title, body = String.repeat 5 title }
else
Nothing
)
|> List.take 5
|> eventually
getPost : Int -> Task String Post
getPost postId =
case
allPosts
|> List.filterMap
(\( id, title, _ ) ->
if id == postId then
Just { id = id, title = title, body = String.repeat 5 title }
else
Nothing
)
|> List.head
of
Nothing ->
Process.sleep 400 |> Task.andThen (\_ -> Task.fail "Ooops")
Just p ->
eventually p
allCommenters =
[ "John Applessed", "Martin Richman", "Johnny Johnerson", "Linda Linderson", "Mary Maryson" ]
allComments =
[ "Awesome article!", "This was disapointing?", "Have you heard about Elm?" ]
getComments : Int -> Task x (List Comment)
getComments id =
allPosts
|> List.filterMap
(\( postId, _, count ) ->
if id == postId then
Just count
else
Nothing
)
|> List.concatMap
(\count ->
List.map2 Comment
(List.concat (List.repeat (count // 3 + 1) allCommenters))
(List.concat (List.repeat (count // 5 + 1) allComments))
|> List.take count
)
|> eventually
Raw
todos.md

TODOs:

  • Richer error handling

  • Encapsulate stuff behind opaque types and make a proper safe API

  • Add a codec for doing lists or other collections (this will require most likely some clever query string work...)

  • Have better handling for emtpy strings (i.e. right now you end up with urls like /index// in the demo app

  • Deal with query max length in some interesting way - perhaps switch to a compressed scheme

  • Figure out a way to integrate this with the Effect pattern (probably via something like elm-procedure)

  • Can we restore the model only partially when going backwards in history? Perhaps clever diffing of partially encoded urls?

  • Add debouncing for replace / push state calls

  • Add richer customization to the URL encoding process, like adding field names (so instead of /1/foo, you could have /user/1/resource/foo if you want)

  • Figure out an API for lazy loaded resources. Now the example has to wait for the comments to load, as there is no way to otherwise initialize the appropriate Cmd. I would like to do something like:

    detailRouter : Router () ( Post, Remote (List Comment) )
detailRouter =
     URLCoders.partialWithLazy (Tuple.first >> .id)
         (\_ id ->
             (Task.map (\post -> (post, Loading)) (getPost id) 
                 |> Task.mapError (always URLCoders.RoutingError)
             , Task.perform LoadedComments (getComments id)
             )
         )
         URLCoders.int
         |> URLCoders.pushUrlOnChange

    However, the library would need to ensure that the message coming in from that command in only delivered once we have a valid model to actually call the update function.

Raw
URLCoders.elm
module URLCoders exposing (CustomTypeRouter, Remote, Router, RoutingError, application, bimap, bimap2, buildCustom, custom, customRouter, default, incidental, int, partial, pushUrlOnChange, string, variant0, variant1, variant2)
{-|
@docs CustomTypeRouter, Remote, Router, RoutingError, application, bimap, bimap2, buildCustom, custom, customRouter, default, incidental, int, partial, pushUrlOnChange, string, variant0, variant1, variant2
-}
import Browser
import Browser.Navigation
import Dict exposing (Dict)
import Html
import Platform exposing (Task)
import Task
import Url exposing (Url)
-- Router API
{-| TODO: Make a richer error type
-}
type RoutingError
= RoutingError
{-| URLCoder or Router? Not sure about the terminology yet, but this is the main type here
-}
type alias Router flags model =
{ encode : model -> Encoding
, decode : Parser flags model
}
type alias Parser flags a =
State flags -> Task RoutingError ( State flags, a )
type alias State flags =
{ pathSegments : List String
, queryParams : Dict String (List String)
, flags : flags
, focus : Focus
}
type Encoded
= None
| Value String
| Concatenation (List Encoding)
type alias Encoding =
{ encoded : Encoded
, push : Bool
}
type Focus
= Path
| Query
| QueryKey String
mkEncoding : Encoded -> Encoding
mkEncoding enc =
{ encoded = enc, push = False }
{-| This is a coder that deals with a piece of model state that simply has no place in the URL.
It allows you to read it in from flags or run an effect to fetch it.
Examples: current user, current time, device class
-}
incidental : (flags -> Task RoutingError model) -> Router flags model
incidental initializer =
{ encode = always (mkEncoding None)
, decode = \state -> Task.map (\val -> ( state, val )) (initializer state.flags)
}
{-| Like incidental, but a for a value that is OK to be some static default value.
Examples: isAnimating, dragState
-}
default : a -> Router flags a
default val =
incidental (always (Task.succeed val))
{-| A piece in the model where we want to encode only some small part (like an ID), that
we can then restore the full value from.
Examples: Any thing that we want to fetch from the server.
-}
partial : (model -> a) -> (flags -> a -> Task RoutingError model) -> Router flags a -> Router flags model
partial get build subRouter =
{ encode = get >> subRouter.encode
, decode =
\state ->
subRouter.decode state
|> Task.andThen
(\( newState, value ) ->
Task.map (\val -> ( newState, val )) (build newState.flags value)
)
}
{-| Like map, but you have to provide functions that go both ways.
-}
bimap : (b -> a) -> (a -> b) -> Router flags a -> Router flags b
bimap fn2 fn1 router =
{ encode = \model -> router.encode (fn2 model)
, decode =
\state ->
router.decode state
|> Task.map (Tuple.mapSecond fn1)
}
bimap2 : (model -> a) -> (model -> b) -> (a -> b -> model) -> Router flags a -> Router flags b -> Router flags model
bimap2 fst sec compose a b =
{ encode =
\model ->
mkEncoding (Concatenation [ a.encode (fst model), b.encode (sec model) ])
, decode =
\state ->
a.decode state
|> Task.andThen
(\( newState, aVal ) ->
Task.map (\( newerState, bVal ) -> ( newerState, compose aVal bVal )) (b.decode newState)
)
}
{-| Build a router for a custom thing.
Not sure this is safe at the moment...
-}
customRouter : (a -> String) -> (String -> Maybe a) -> Router flags a
customRouter encoder parser =
{ encode =
\v ->
mkEncoding (Value (encoder v))
, decode =
\state ->
case state.focus of
Path ->
case state.pathSegments of
[] ->
Task.fail RoutingError
next :: rest ->
case parser next of
Just res ->
Task.succeed ( { state | pathSegments = rest }, res )
Nothing ->
Task.fail RoutingError
Query ->
Task.fail RoutingError
QueryKey key ->
case Dict.get key state.queryParams of
Just (val :: other) ->
case parser val of
Just res ->
Task.succeed ( { state | queryParams = Dict.insert key other state.queryParams }, res )
Nothing ->
Task.fail RoutingError
_ ->
Task.fail RoutingError
}
{-| -}
int : Router flags Int
int =
customRouter String.fromInt String.toInt
{-| -}
string : Router flags String
string =
customRouter identity Just
type CustomTypeRouter flags match value
= CustomTypeRouter
{ match : match
, decode : Dict String (Parser flags value)
}
{-| Build a custom type encoder. See elm-json-codec for docs.
-}
custom : match -> CustomTypeRouter flags match value
custom match =
CustomTypeRouter { match = match, decode = Dict.empty }
variant : String -> ((List Encoding -> Encoding) -> a) -> Parser flags v -> CustomTypeRouter flags (a -> b) v -> CustomTypeRouter flags b v
variant name matchPiece decoderPiece (CustomTypeRouter am) =
let
enc v =
mkEncoding (Concatenation (mkEncoding (Value name) :: v))
in
CustomTypeRouter
{ match = am.match <| matchPiece enc
, decode = Dict.insert name decoderPiece am.decode
}
variant0 : String -> v -> CustomTypeRouter flags (Encoding -> a) v -> CustomTypeRouter flags a v
variant0 name ctor =
variant name (\c -> c []) (\state -> Task.succeed ( state, ctor ))
variant1 : String -> (a -> v) -> Router flags a -> CustomTypeRouter flags ((a -> Encoding) -> b) v -> CustomTypeRouter flags b v
variant1 name ctor m1 =
variant name
(\c v -> c [ m1.encode v ])
(\state ->
m1.decode state
|> Task.map (Tuple.mapSecond ctor)
)
variant2 : String -> (a -> b -> v) -> Router flags a -> Router flags b -> CustomTypeRouter flags ((a -> b -> Encoding) -> x) v -> CustomTypeRouter flags x v
variant2 name ctor m1 m2 =
variant name
(\c v1 v2 -> c [ m1.encode v1, m2.encode v2 ])
(\state ->
m1.decode state
|> Task.andThen
(\( newState, aVal ) ->
Task.map (\( newerState, bVal ) -> ( newerState, ctor aVal bVal )) (m2.decode newState)
)
)
buildCustom : CustomTypeRouter flags (a -> Encoding) a -> Router flags a
buildCustom (CustomTypeRouter am) =
{ encode = \v -> am.match v
, decode =
\state ->
string.decode state
|> Task.andThen
(\( newState, tag ) ->
case Dict.get tag am.decode of
Nothing ->
Task.fail RoutingError
Just dec ->
dec newState
)
}
{-| Codecs will normally call replaceUrl for you. You can change a Router to call pushState when the piece it's managing changes.
-}
pushUrlOnChange : Router flags model -> Router flags model
pushUrlOnChange router =
{ router
| encode =
\v ->
let
encoded =
router.encode v
in
{ encoded | push = True }
}
-- Runtime
type Remote model
= Loading
| Loaded model
| Error
type alias Model model flags =
{ key : Browser.Navigation.Key
, url : String
, model : Remote model
, processingUrlChange : Bool
, flags : flags
}
type URLAction
= Same
| Replace
| Push
diffEncoding : Encoding -> Encoding -> URLAction
diffEncoding old new =
case ( old.encoded, new.encoded ) of
( None, None ) ->
Same
( Value a, Value b ) ->
if a == b then
Same
else
toAction new
( Concatenation aList, Concatenation bList ) ->
if List.length aList == List.length bList then
List.map2 diffEncoding aList bList
|> List.foldr concatUrlAction Same
else
toAction new
_ ->
toAction new
concatUrlAction : URLAction -> URLAction -> URLAction
concatUrlAction a b =
case a of
Push ->
Push
Replace ->
if b == Push then
Push
else
Replace
Same ->
b
toAction : { a | push : Bool } -> URLAction
toAction { push } =
if push then
Push
else
Replace
encodingToStr : Encoding -> String
encodingToStr { encoded } =
case encoded of
None ->
""
Value str ->
Url.percentEncode str
Concatenation segments ->
String.join "/" (List.map encodingToStr segments)
decodeUrl : Router flags model -> flags -> Url.Url -> Task RoutingError model
decodeUrl { decode } flags url =
decode
{ pathSegments =
case String.split "/" url.path of
"" :: segments ->
removeFinalEmpty segments
segments ->
removeFinalEmpty segments
, queryParams =
case url.query of
Nothing ->
Dict.empty
Just qry ->
List.foldr addParam Dict.empty (String.split "&" qry)
, flags = flags
, focus = Path
}
|> Task.map Tuple.second
removeFinalEmpty : List String -> List String
removeFinalEmpty segments =
case segments of
[] ->
[]
"" :: [] ->
[]
segment :: rest ->
segment :: removeFinalEmpty rest
addParam : String -> Dict String (List String) -> Dict String (List String)
addParam segment dict =
case String.split "=" segment of
[ rawKey, rawValue ] ->
case Url.percentDecode rawKey of
Nothing ->
dict
Just key ->
case Url.percentDecode rawValue of
Nothing ->
dict
Just value ->
Dict.update key (addToParametersHelp value) dict
_ ->
dict
addToParametersHelp : a -> Maybe (List a) -> Maybe (List a)
addToParametersHelp value maybeList =
case maybeList of
Nothing ->
Just [ value ]
Just list ->
Just (value :: list)
{-| The entrypoint. Notice how straightforward this is compared to Browswer.application.
-}
application :
{ view : model -> Browser.Document msg
, update : msg -> model -> ( model, Cmd msg )
, subscriptions : model -> Sub msg
, router : Router flags model
}
-> Program flags (Model model flags) (Msg msg model)
application config =
Browser.application
{ init = init config.router
, view = view config.view
, update = update config.update config.router
, subscriptions = subscriptions config.subscriptions
, onUrlRequest = \urlRequest -> loadURL urlRequest
, onUrlChange = OnUrlChange
}
init coder flags url key =
( { key = key
, url = Url.toString url
, model = Loading
, processingUrlChange = False
, flags = flags
}
, decodeUrl coder flags url
|> Task.attempt LoadingComplete
)
view userView model =
case model.model of
Loading ->
{ title = "", body = [ Html.text "Loading..." ] }
Error ->
{ title = "", body = [ Html.text "Something went wrong..." ] }
Loaded m ->
let
res =
userView m
in
{ title = res.title, body = List.map (Html.map UserMsg) res.body }
loadURL : Browser.UrlRequest -> Msg msg model
loadURL =
LoadRequest
type Msg msg model
= UserMsg msg
| LoadRequest Browser.UrlRequest
| LoadingComplete (Result RoutingError model)
| OnUrlChange Url
update : (msg -> model -> ( model, Cmd msg )) -> Router flags model -> Msg msg model -> Model model flags -> ( Model model flags, Cmd (Msg msg model) )
update userUpdate coder msg model =
case msg of
LoadingComplete (Ok newModel) ->
( { model | model = Loaded newModel }, Cmd.none )
LoadingComplete (Err _) ->
( { model | model = Error }, Cmd.none )
LoadRequest urlRequest ->
case urlRequest of
Browser.Internal url ->
let
_ =
Debug.log "internal" url
in
( model, Cmd.none )
Browser.External str ->
( model, Browser.Navigation.load str )
OnUrlChange url ->
if model.processingUrlChange then
( { model | processingUrlChange = False }, Cmd.none )
else
init coder model.flags url model.key
UserMsg userMsg ->
case model.model of
Loaded userModel ->
let
( newUserModel, cmd ) =
userUpdate userMsg userModel
newEncoding =
coder.encode newUserModel
( processing, urlCommand ) =
case diffEncoding (coder.encode userModel) newEncoding of
Same ->
( False, Cmd.none )
Replace ->
( True, Browser.Navigation.replaceUrl model.key ("/" ++ encodingToStr newEncoding |> Debug.log "replace") )
Push ->
( True, Browser.Navigation.pushUrl model.key ("/" ++ encodingToStr newEncoding |> Debug.log "push") )
in
( { model | model = Loaded newUserModel, processingUrlChange = processing }, Cmd.batch [ Cmd.map UserMsg cmd, urlCommand ] )
Loading ->
Debug.todo """
we need to process returning msg from commands here in order to construct
the initial model here, however, we need to do it without the model.
The ideal option here is that initialization is just a `Task Error Model`,
which would work for:
- HTTP
- Viewport
- Time
But would not work for:
- Ports
- Random
- Complex HTTP
I think the killer here really is ports. But can ports even be used for "automatic" initialization?
Surely, that would require request/response semantics...
I'll currently go with a task based approach, but if you need something to do with request/response ports,
then checkout brian-watkins/elm-procedure for an approach of having a seperate hidden model to manage
series of commands, tasks and subscriptions in transparent form.
"""
_ ->
Debug.todo "I think this should be impossible... Probably we're ok to ignore?"
subscriptions : (model -> Sub msg) -> Model model flags -> Sub (Msg msg model)
subscriptions userSubscriptions model =
case model.model of
Loaded userModel ->
Sub.map UserMsg (userSubscriptions userModel)
_ ->
Sub.none
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment