Routing.lhs

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 == '/'