public
Last active

  • Download Gist
Routing2.lhs
Literate Haskell
{-# 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.