Skip to content

@chriseidhof /Routing.lhs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
This is a literate Haskell file that describes the sketch of a type-safe URL
handling system. It is not done (or anything near it), but is intended as
inspiration for a complete system.
First we will show some examples, and later we will implement the library. The
library uses the |regular| package for generic programming (cabal install regular).
> {-# LANGUAGE TemplateHaskell, TypeFamilies, EmptyDataDecls,
> TypeSynonymInstances, TypeOperators, ScopedTypeVariables #-}
>
> module Routing where
>
> import Generics.Regular
> import Data.Char (toLower)
> import Data.List (intercalate)
For every component (e.g., virtual URL directory) we define a datatype. Here's
the part for the |User| component.
> data UserRoute = List
> | Find Int
> | Name String
> deriving Show
>
> data ApplicationRoute = Login
> | User UserRoute
> deriving Show
This is some TH code which is necessary for using the Regular library:
> $(deriveAll ''UserRoute "PFUserRoute")
> type instance PF UserRoute = PFUserRoute
> $(deriveAll ''ApplicationRoute "PFApplicationRoute")
> type instance PF ApplicationRoute = PFApplicationRoute
And here are some instances. These are the same for every datatype (so yes,
there's room for improvement ;)).
> instance ToURL UserRoute where
> toURL = gtoURL . from
> fromURL = fmap to . gfromURL
> instance ToURL ApplicationRoute where
> toURL = gtoURL . from
> fromURL = fmap to . gfromURL
This is all we have to do! Let's take a look at some examples:
> loginUrl = renderURL (toURL Login)
This renders to "login"
> userFiveURl = renderURL (toURL (User (Find 5)))
This renders to "users/find/5"
> testRoute :: Maybe ApplicationRoute
> testRoute = fromURL (components "user/name/chris")
This is parsed as Just (User (Name "chris"))
> invalidURLs :: [Maybe ApplicationRoute]
> invalidURLs = [ fromURL (components "nonsense")
> , fromURL (components "user/find")
> , fromURL (components "user/find/5/more")
> ]
This fails and is parsed as Nothing. Of course, we could also do error handling.
From here on we will define the library. For now, we will use |String|s as our |URL|
types, but this should of course be a proper URL type.
> type URL = [String]
> (</>) :: URL -> URL -> URL
> renderURL :: URL -> String
> components :: String -> URL
We will need two typeclasses. One for the generic functionality, |GToURL|, and one for the
normal datatypes, |ToURL|.
> class GToURL f where
> gtoURL :: f a -> URL
> gfromURL :: URL -> Maybe (f a)
> instance ToURL a => GToURL (K a) where
> gtoURL (K a) = toURL a
> gfromURL x = fmap K (fromURL x)
>
> instance (GToURL f, GToURL g) => GToURL (f :+: g) where
> gtoURL (L x) = gtoURL x
> gtoURL (R y) = gtoURL y
> gfromURL s = let urlLeft = fmap L (gfromURL s)
> urlRight = fmap R (gfromURL s)
> in case urlLeft of
> Nothing -> urlRight
> x -> x
> instance GToURL U where
> gtoURL U = []
> gfromURL [] = Just U
> gfromURL _ = Nothing
> instance GToURL f => GToURL (S s f) where
> gtoURL (S x) = gtoURL x
> gfromURL x = fmap S (gfromURL x)
> instance (Constructor c, GToURL f) => GToURL (C c f) where
> gtoURL c@(C x) = [lower $ conName c] </> gtoURL x
> gfromURL (x:xs) = let constr = undefined :: C c f r
> name = conName constr
> in if (lower x == lower name)
> then fmap C (gfromURL xs)
> else Nothing
> class ToURL a where
> toURL :: a -> URL
> fromURL :: URL -> Maybe a
> instance ToURL String where
> toURL x = [show x] -- there should be escaping here!!
> fromURL [x] = Just x
> fromURL _ = Nothing
> instance ToURL Int where
> toURL x = [show x]
> fromURL [x] = Just (read x) -- completely unsafe read. what if read fails?
> fromURL _ = Nothing
Some utility functions:
> lower = map toLower
> l </> r = l ++ r
> renderURL = intercalate "/"
> components s = case dropWhile isSlash s of
> "" -> []
> s' -> w : components s''
> where (w, s'') = break isSlash s'
> where isSlash x = x == '/'
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.