Routing2.lhs

> {-# LANGUAGE GADTs, TypeOperators, TupleSections #-}
> module Routing2 where

> import Control.Applicative hiding (many, (<|>))
> import Text.ParserCombinators.Parsec.Prim
> import Text.ParserCombinators.Parsec.Error
> import Text.ParserCombinators.Parsec.Char
> import Text.ParserCombinators.Parsec.Combinator

> import Data.List (intercalate)

In this file we build another routing library. This library couples the routes
and the handler functions. As an example, consider the following schema:

Note that all the handler functions have the same result type (String). In a
Happstack application, it would be ServerPart instead of String.

> mySchema :: [Route String]
> mySchema = 
>  [ handleIndex  <$  Index
>  , handleUser   <$  Dir "user"   <*> Int
>  , handleStatic <$  Dir "static" <*> Rest
>  ]

> handleIndex  :: String
> handleUser   :: Int -> String
> handleStatic :: [String] -> String

> handleIndex  = "index!"
> handleUser x = "looking up user: " ++ show x
> handleStatic = unlines

Try printing mySchema in GHCi.

We can build a |test| function that finds the correct handler for us:

> test :: [String] -> Either ParseError String
> test = parse (parseRoutes mySchema) ""

All these should deliver an IO action (wrapped in a Right)

> succeed1 = test [] 
> succeed2 = test ["user", "27"]
> succeed3 = test ["static", "some", "more"]

These tests should give an error message.

> fail1    = test ["hi"]
> fail2    = test ["user","a string"]

Now we proceed with the library definition:

> instance Show (Route a) where
>  show = intercalate "/" . showRoute

> data Route a where
>  Index   :: Route ()
>  Dir     :: String -> Route ()
>  String  :: Route String
>  Int     :: Route Int
>  Rest    :: Route [String]
>  Pure    :: p -> Route p
>  (:*:)   :: Route (a -> b) -> Route a -> Route b

> instance Functor Route where
>   fmap f = (:*:) (Pure f)

> instance Applicative Route where
>   pure  = Pure
>   (<*>) = (:*:)


> parseRoute :: Route a -> URLParser a
> parseRoute Index      = eof >> return ()
> parseRoute (Dir d)    = segment d >> return ()
> parseRoute (String)   = anySegment
> parseRoute (Int)      = parseInt
> parseRoute Rest       = many anySegment
> parseRoute (Pure p)   = return p
> parseRoute (l :*:r )  = do l' <- parseRoute l
>                            r' <- parseRoute r
>                            return (l' r')

> type URLSchema a = [Route a]

> parseRoutes :: URLSchema a -> URLParser a
> parseRoutes = choice . map parseRoute

A utility function. Could be used by Template Haskell.

> isValidRoute :: URLSchema a -> [String] -> Bool
> isValidRoute schema route = 
>  case parse (parseRoutes schema) "" route of
>    Left  _ -> False
>    Right _ -> True

> showRoute :: Route a -> [String]
> showRoute Index     = [""]
> showRoute (Dir d)   = [d]
> showRoute String    = ["$"]
> showRoute Int       = ["#"]
> showRoute Rest      = ["*"]
> showRoute (Pure _)  = []
> showRoute (l :*: r) = showRoute l ++ showRoute r


Now the URL parsing functionality from the previous time:

> type URLParser a = GenParser String () a
> 
> segment :: String -> URLParser String
> segment x = pToken (const x) (\y -> if x == y then Just x else Nothing)
> 
> anySegment :: URLParser String
> anySegment = pToken (const "any string") Just
> 
> pToken msg f = do pos <- getPosition
>                   token id (const pos) f
> 
> parseInt :: URLParser Int
> parseInt = pToken (const "integer") checkInt
>   where checkInt str = 
>           case reads str of
>             [(n,[])] -> Just n
>             _ ->        Nothing