public
Created

  • Download Gist
Routing.lhs
Literate Haskell

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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.