wai-routes 0.1 → 0.2

raw patch · 6 files changed

+425/−363 lines, 6 filesdep +mtldep +yesod-routesdep ~http-typesdep ~waiPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, yesod-routes

Dependency ranges changed: http-types, wai

API changes (from Hackage documentation)

Files

• README +43/−29
• examples/Example.hs +126/−0
• src/Network/Wai/Middleware/Routes.hs +5/−326
• src/Network/Wai/Middleware/Routes/Monad.hs +79/−0
• src/Network/Wai/Middleware/Routes/Routes.hs +116/−0
• wai-routes.cabal +56/−8

@@ -1,54 +1,68 @@-Wai Routes (wai-routes-0.1)+Wai Routes (wai-routes-0.2) ============================  This package provides typesafe URLs for Wai applications. -Much of the TH functionality has been lifted from Yesod dispatching code. The aim is to provide a similar level of typesafe URL functionality to Wai applications as is available to Yesod applications.+Features:+  - Automatic generation of Route boilerplate using TH+  - Easy Nested Routes+  - Sitewide Master datatype which is passed to all handlers+    and can be used for persistent data (like DB connections)+  - RouteM monad that makes it easy to compose an application+    with multiple routes and middleware. +It depends on yesod-routes package for the TH functionality (but not the rest of yesod). The aim is to provide a similar level of typesafe URL functionality to Wai applications as is available to Yesod applications. + Example Usage =============  The following builds a simple JSON service (using Aeson for JSON conversion)  -    -- A useful type synonym-    type UserId = Text+    {-# LANGUAGE OverloadedStrings, TypeFamilies #-} -    -- Define the JSON instance-    data User = User { name::Text, uid:: UserId } deriving (Show, Read, Eq)-    instance ToJSON User where-      toJSON x = object [ "name" .= (name x), "uid" .= (uid x) ]+    import Network.Wai+    import Network.Wai.Middleware.Routes -    -- Define the handlers-    getUserR :: UserId -> Application-    getUserR uid _req =-      return $ responseLBS statusOK headers json-      where user = User { name = "Anon Amos", uid = uid }-            json = encode user-            headers = [("Content-Type", "application/json")]+    import Data.IORef -    getUsersR :: Application-    getUsersR _req =-      return $ responseLBS statusOK headers json-      where userids = (["anon","john","jane"]::[Text])-            json = encode userids-            headers = [("Content-Type", "application/json")]+    -- The Site Argument+    data MyRoute = MyRoute (IORef DB) -    -- Generate the routing datatype and the Route instance-    -- The type generated will be named "UserRoute"-    mkRoute "User" [parseRoutes|-      /users UsersR GET-      /user/#UserId UserR GET-    |]+    -- Generate Routes+    mkRoute MyRoute [parseRoutes|+    /             UsersR         GET+    /user/#Int    UserR:+      /              UserRootR   GET+      /delete        UserDeleteR POST+    [| -    -- Now you can use dispatch function (passing it your route datatype)+    -- Define Handlers+    -- All Users Page+    getUsersR :: Handler MyRoute+    getUsersR (MyRoute dbref) request = ...+    -- Single User Page+    getUserRootR :: Int -> Handler MyRoute+    getUserRootR userid (MyRoute dbref) request = ...+    -- Delete Single User+    postUserDeleteR :: Int -> Handler MyRoute+    postUserDeleteR userid (MyRoute dbref) request = ...++    -- Define Application using RouteM Monad+    myApp = do+      db <- liftIO $ newIORef mydb+      route (MyRoute db)+      setDefaultAction $ staticApp $ defaultFileServerSettings "static"++    -- Run the application     main :: IO ()-    main = run 8080 $ dispatch (undefined::UserRoute) $ staticApp defaultFileServerSettings+    main = toWaiApp myApp >>= run 8080   Changelog =========  0.1 : Intial release+0.2 : Updated functionality based on yesod-routes package 

@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}+module Main where++import Network.Wai+import Network.Wai.Middleware.Routes+import Network.Wai.Application.Static+import Network.Wai.Handler.Warp+import Network.HTTP.Types+import qualified Data.Text as T+import Data.Text (Text)+import Data.Aeson+import Data.IORef+import qualified Data.Map as M+import Control.Monad.Trans++-- The database of users+data User = User+  { userId   :: Int+  , userName :: Text+  , userAge  :: Int+  } deriving (Show, Read, Eq)+type DB = [User]++-- JSON instance+instance ToJSON User where+  toJSON x = object [ "uid" .= (userId x), "name" .= (userName x), "age" .= (userAge x) ]+++-- The Site argument+data MyRoute = MyRoute (IORef DB)++-- Make MyRoute Routable+mkRoute "MyRoute" [parseRoutes|+/             HomeR            GET+/users        UsersR           GET+/user/#Int    UserR:+    /              UserRootR   GET+    /delete        UserDeleteR GET POST+|]++-- Our handlers always produce json+jsonHeaders = [("Content-Type", "application/json")]++-- Handlers++-- Display the possible actions+getHomeR :: Handler MyRoute+getHomeR _master _req = return $ responseLBS status200 jsonHeaders json+  where json = encode $ M.fromList (+                 [("description", [["Simple User database Example"]])+                 ,("links"+                  ,[["home",  showRoute HomeR]+                   ,["users", showRoute UsersR]+                   ]+                  )+                 ] :: [(Text, [[Text]])] )++-- Display all the users+getUsersR :: Handler MyRoute+getUsersR (MyRoute dbref) req_ = do+  db <- liftIO $ readIORef dbref+  let dblinks = map linkify db+  let json = encode $ M.fromList (+          [("description", [["Users List"]])+          ,("links", dblinks)] :: [(Text, [[Text]])] )+  return $ responseLBS status200 jsonHeaders json+  where+    linkify user = [userName user, showRoute $ UserR (userId user) UserRootR]++-- Display a single user+getUserRootR :: Int -> Handler MyRoute+getUserRootR i (MyRoute dbref) _req = do+  db <- liftIO $ readIORef dbref+  let user = ulookup i db+  case ulookup i db of+    Nothing -> return $ responseLBS status200 jsonHeaders $ encode ("ERROR: User not found" :: Text)+    Just user -> do+      let json = encode $ M.fromList (+            [("description", [["User details"]])+            ,("data"+             ,[["Id",   T.pack $ show $ userId user]+              ,["Name", userName user]+              ,["Age",  T.pack $ show $ userAge user]+              ]+             )+            ,("links"+             ,[["details",            showRoute $ UserR (userId user) UserRootR]+              ,["delete (post only)", showRoute $ UserR (userId user) UserDeleteR]+              ]+             )+            ] :: [(Text, [[Text]])] )+      return $ responseLBS status200 jsonHeaders json+  where+    ulookup _ [] = Nothing+    ulookup i (u:us) = if userId u == i then Just u else ulookup i us++-- Delete a user: GET+getUserDeleteR :: Int -> Handler MyRoute+getUserDeleteR _ master req_ = return $ responseLBS status200 jsonHeaders json+  where err = (["DELETE","please use POST"]::[Text])+        json = encode err++-- Delete a user: POST+postUserDeleteR :: Int -> Handler MyRoute+postUserDeleteR _ master req_ = return $ responseLBS status200 jsonHeaders json+  where err = (["DELETE","not implemented"]::[Text])+        json = encode err++-- Initial database+initdb =+    [ User 1 "Anon Amos" 23+    , User 2 "Bo Lively" 28+    ]++-- The application that uses our route+-- NOTE: We use the Route Monad to simplify routing+application :: RouteM ()+application = do+  db <- liftIO $ newIORef initdb+  route (MyRoute db)+  setDefaultAction $ staticApp $ defaultFileServerSettings "static"++-- Run the application+main :: IO ()+main = toWaiApp application >>= run 8080+

@@ -1,6 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-} {- | Module      :  Network.Wai.Middleware.Routes Copyright   :  (c) Anupam Jain 2011@@ -13,329 +10,11 @@ This package provides typesafe URLs for Wai applications. -} module Network.Wai.Middleware.Routes-    ( parseRoutes-    , parseRoutesFile-    , parseRoutesNoCheck-    , parseRoutesFileNoCheck-    , mkRoute-    , dispatch-    , Resource (..)-    , Piece (..)-    , Route (..)-    ) where--import Web.PathPieces-import Network.Wai-import Language.Haskell.TH.Syntax-import Data.Maybe-import Data.Either-import Data.List-import Data.Char (toLower)-import qualified Data.Text-import Language.Haskell.TH.Quote-import Data.Data-import qualified System.IO as SIO-import Data.Text (Text)-import Network.HTTP.Types (StdMethod(..), statusOK, statusNotAllowed, parseMethod)---- | Instances of this class are autogenerated by @mkRoute@ TH function-class Route route where-  showRoute :: route -> [Text]-  readRoute :: [Text] -> Either String route-  dispatchRoute :: route -> String -> Maybe Application---- | The application dispatcher function.--- This function takes an instance of @Route@ class as an argument.--- It is normal to pass (undefined::YourRoute).-dispatch :: Route route => route -> Middleware-dispatch route def req = case readRoute (pathInfo req) of-  Left s -> def req-  Right route' -> case dispatchRoute (route' `asTypeOf` route) (show $ method req) of-    Nothing -> def req-    Just app -> app req+  ( module Network.Wai.Middleware.Routes.Routes+  , module Network.Wai.Middleware.Routes.Monad+  )   where-    method :: Request -> StdMethod-    method req = case parseMethod $ requestMethod req of-      Right m -> m-      Left  _ -> GET --- | Call this function to automatically generate your route datatype and @Route@ instance -mkRoute :: String -> [Resource] -> Q [Dec]-mkRoute name res = do-    cons <- createRoutes res-    let routesName = mkName $ name ++ "Route"-    let dataDecl = DataD [] routesName [] cons [''Show, ''Read, ''Eq]-    render <- createRender res-    reader <- createParse res-    dispatch <- createDispatch res-    let routeInstance = InstanceD [] (ConT ''Route `AppT` ConT routesName) [ FunD (mkName "showRoute") render , FunD (mkName "readRoute") reader, FunD (mkName "dispatchRoute") dispatch ]-    return [dataDecl, routeInstance]--createRoutes :: [Resource] -> Q [Con]-createRoutes res = return $ map go res-  where-    go (Resource n pieces _) = NormalC (mkName n) $ mapMaybe go' pieces-    go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)-    go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)-    go' (StaticPiece _) = Nothing--createParse :: [Resource] -> Q [Clause]-createParse res = do-    final' <- final-    clauses <- mapM go res-    return $ if areResourcesComplete res-                then clauses-                else clauses ++ [final']-  where-    cons x y = ConP (mkName ":") [x, y]-    go (Resource n ps _) = do-        ri <- [|Right|]-        be <- [|ape|]-        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)-        return $ Clause [foldr1 cons pat] (NormalB parse) []-    final = do-        no <- [|Left "Invalid URL"|]-        return $ Clause [WildP] (NormalB no) []-    mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)-    mkPat' be [MultiPiece s] parse = do-        v <- newName $ "var" ++ s-        fmp <- [|fromPathMultiPiece|]-        let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v-        return ([VarP v], parse')-    mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"-    mkPat' be (StaticPiece s:rest) parse = do-        (x, parse') <- mkPat' be rest parse-        let sp = LitP $ StringL s-        return (sp : x, parse')-    mkPat' be (SinglePiece s:rest) parse = do-        fsp <- [|fromPathPiece|]-        v <- newName $ "var" ++ s-        let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v-        (x, parse'') <- mkPat' be rest parse'-        return (VarP v : x, parse'')-    mkPat' _ [] parse = return ([ListP []], parse)--ape :: Either String (a -> b) -> Maybe a -> Either String b-ape (Left e) _ = Left e-ape (Right _) Nothing = Left "Invalid URL"-ape (Right f) (Just a) = Right $ f a--createRender :: [Resource] -> Q [Clause]-createRender = mapM go-  where-    go (Resource n ps _) = do-        let ps' = zip [1..] ps-        let pat = ConP (mkName n) $ mapMaybe go' ps'-        bod <- mkBod ps'-        return $ Clause [pat] (NormalB bod) []-    go' (_, StaticPiece _) = Nothing-    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)-    mkBod :: (Show t) => [(t, Piece)] -> Q Exp-    mkBod [] = lift ([] :: [String])-    mkBod ((_, StaticPiece x):xs) = do-        x' <- lift x-        pack <- [|Data.Text.pack|]-        xs' <- mkBod xs-        return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'-    mkBod ((i, SinglePiece _):xs) = do-        let x' = VarE $ mkName $ "var" ++ show i-        tsp <- [|toPathPiece|]-        let x'' = tsp `AppE` x'-        xs' <- mkBod xs-        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'-    mkBod ((i, MultiPiece _):_) = do-        let x' = VarE $ mkName $ "var" ++ show i-        tmp <- [|toPathMultiPiece|]-        return $ tmp `AppE` x'--areResourcesComplete :: [Resource] -> Bool-areResourcesComplete res =-    let (slurps, noSlurps) = partitionEithers $ mapMaybe go res-     in case slurps of-            [] -> False-            _ -> let minSlurp = minimum slurps-                  in helper minSlurp $ reverse $ sort noSlurps-  where-    go :: Resource -> Maybe (Either Int Int)-    go (Resource _ ps _) =-        case reverse ps of-            [] -> Just $ Right 0-            (MultiPiece _:rest) -> go' Left rest-            x -> go' Right x-    go' b x = if all isSingle x then Just (b $ length x) else Nothing-    helper 0 _ = True-    helper _ [] = False-    helper m (i:is)-        | i >= m = helper m is-        | i + 1 == m = helper i is-        | otherwise = False-    isSingle (SinglePiece _) = True-    isSingle _ = False--notStatic :: Piece -> Bool-notStatic StaticPiece{} = False-notStatic _ = True--createDispatch :: [Resource] -> Q [Clause]-createDispatch = mapM go-  where-    go :: Resource -> Q Clause-    go (Resource n ps methods) = do-        meth <- newName "method"-        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"-        let pat = [ ConP (mkName n) $ map VarP xs-                  , if null methods then WildP else VarP meth-                  ]-        bod <- go' n meth xs methods-        return $ Clause pat (NormalB bod) []-    go' n _ xs [] = do-        jus <- [|Just|]-        let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs-        return $ jus `AppE` bod-    go' n meth xs methods = do-        noth <- [|Nothing|]-        j <- [|Just|]-        let noMatch = Match WildP (NormalB noth) []-        return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]-    go'' n xs j method =-        let pat = LitP $ StringL method-            func = map toLower method ++ n-            bod = foldl AppE (VarE $ mkName func) $ map VarE xs-         in Match pat (NormalB $ j `AppE` bod) []---- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for--- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the--- checking-parseRoutes :: QuasiQuoter-parseRoutes = QuasiQuoter-    { quoteExp = x-    , quotePat = y-    }-  where-    x s = do-        let res = resourcesFromString s-        case findOverlaps res of-            [] -> lift res-            z -> error $ "Overlapping routes: " ++ unlines (map show z)-    y = dataToPatQ (const Nothing) . resourcesFromString---- | A quasi-quoter to parse the contents of a file into a list of 'Resource's. Checks for--- overlapping routes, failing if present; use 'parseRoutesFileNoCheck' to skip the--- checking-parseRoutesFile :: FilePath -> Q Exp-parseRoutesFile fp = do-    s <- qRunIO $ readUtf8File fp-    quoteExp parseRoutes s---- | Same as 'parseRoutesFile', but performs no overlap checking.-parseRoutesFileNoCheck :: FilePath -> Q Exp-parseRoutesFileNoCheck fp = do-    s <- qRunIO $ readUtf8File fp-    quoteExp parseRoutesNoCheck s--readUtf8File :: FilePath -> IO String-readUtf8File fp = do-    h <- SIO.openFile fp SIO.ReadMode-    SIO.hSetEncoding h SIO.utf8_bom-    SIO.hGetContents h---- | Same as 'parseRoutes', but performs no overlap checking.-parseRoutesNoCheck :: QuasiQuoter-parseRoutesNoCheck = QuasiQuoter-    { quoteExp = x-    , quotePat = y-    }-  where-    x = lift . resourcesFromString-    y = dataToPatQ (const Nothing) . resourcesFromString--instance Lift Resource where-    lift (Resource s ps h) = do-        r <- [|Resource|]-        s' <- lift s-        ps' <- lift ps-        h' <- lift h-        return $ r `AppE` s' `AppE` ps' `AppE` h'---- | A single resource pattern.------ First argument is the name of the constructor, second is the URL pattern to--- match, third is how to dispatch.-data Resource = Resource String [Piece] [String]-    deriving (Read, Show, Eq, Data, Typeable)---- | A single piece of a URL, delimited by slashes.------ In the case of StaticPiece, the argument is the value of the piece; for the--- other constructors, it is the name of the parameter represented by this--- piece.-data Piece = StaticPiece String-           | SinglePiece String-           | MultiPiece String-    deriving (Read, Show, Eq, Data, Typeable)--instance Lift Piece where-    lift (StaticPiece s) = do-        c <- [|StaticPiece|]-        s' <- lift s-        return $ c `AppE` s'-    lift (SinglePiece s) = do-        c <- [|SinglePiece|]-        s' <- lift s-        return $ c `AppE` s'-    lift (MultiPiece s) = do-        c <- [|MultiPiece|]-        s' <- lift s-        return $ c `AppE` s'--resourcesFromString :: String -> [Resource]-resourcesFromString =-    mapMaybe go . lines-  where-    go s =-        case takeWhile (/= "--") $ words s of-            (pattern:constr:rest) ->-                let pieces = piecesFromString $ drop1Slash pattern-                 in Just $ Resource constr pieces rest-            [] -> Nothing-            _ -> error $ "Invalid resource line: " ++ s--drop1Slash :: String -> String-drop1Slash ('/':x) = x-drop1Slash x = x--piecesFromString :: String -> [Piece]-piecesFromString "" = []-piecesFromString x =-    let (y, z) = break (== '/') x-     in pieceFromString y : piecesFromString (drop1Slash z)--pieceFromString :: String -> Piece-pieceFromString ('#':x) = SinglePiece x-pieceFromString ('*':x) = MultiPiece x-pieceFromString x = StaticPiece x---- n^2, should be a way to speed it up-findOverlaps :: [Resource] -> [(Resource, Resource)]-findOverlaps = go . map justPieces-  where-    justPieces :: Resource -> ([Piece], Resource)-    justPieces r@(Resource _ ps _) = (ps, r)--    go [] = []-    go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs--    mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->-                Maybe (Resource, Resource)-    mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)-        | x == y = mOverlap (xs, xr) (ys, yr)-        | otherwise = Nothing-    mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)-    mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)-    mOverlap ([], xr) ([], yr) = Just (xr, yr)-    mOverlap ([], _) (_, _) = Nothing-    mOverlap (_, _) ([], _) = Nothing-    mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)--+import Network.Wai.Middleware.Routes.Routes+import Network.Wai.Middleware.Routes.Monad 

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TypeFamilies #-}++{- |+Module      :  Network.Wai.Middleware.Routes.Monad+Copyright   :  (c) Anupam Jain 2011+License     :  GNU GPL Version 3 (see the file LICENSE)++Maintainer  :  ajnsit@gmail.com+Stability   :  experimental+Portability :  non-portable (uses ghc extensions)++Defines a Routing Monad that provides easy composition of Routes+-}+module Network.Wai.Middleware.Routes.Monad+    ( -- * Route Monad+      RouteM+      -- * Compose Routes+    , setDefaultAction+    , middleware+    , route+      -- * Convert to Wai Application+    , toWaiApp+    )+    where++import Network.Wai+import Network.Wai.Middleware.Routes.Routes+import Network.HTTP.Types++import Control.Monad.State++import qualified Data.Text as T++data RouteState = RouteState+                { middlewares :: [Middleware]+                , defaultApp  :: Application+                }++-- The final "catchall" application, simply returns a 404 response+-- Ideally you should put your own default application+defaultApplication :: Application+defaultApplication _req = return $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found"+++addMiddleware :: Middleware -> RouteState -> RouteState+addMiddleware m s@(RouteState {middlewares=ms}) = s {middlewares=m:ms}++setDefaultApp :: Application -> RouteState -> RouteState+setDefaultApp a s@(RouteState {defaultApp=d}) = s {defaultApp=a}++-- ! The Route Monad+newtype RouteM a = S { runS :: StateT RouteState IO a }+    deriving (Monad, MonadIO, Functor, MonadState RouteState)++-- | Add a middleware to the application.+-- Middleware is nested so the one declared earlier is outer.+middleware :: Middleware -> RouteM ()+middleware = modify . addMiddleware++-- | Add a route to the application.+-- Routes are ordered so the one declared earlier is matched first.+route :: (Routable master) => master -> RouteM ()+route = middleware . dispatch++-- ! Set the default action of the Application.+-- You should only call this once in an application.+-- Subsequent invocations override the previous settings.+setDefaultAction :: Application -> RouteM ()+setDefaultAction = modify . setDefaultApp++-- Empty state+initRouteState = RouteState [] defaultApplication++-- | Convert a RouteM Monadic value into a wai application.+toWaiApp :: RouteM () -> IO Application+toWaiApp m = do+  (_,s) <- runStateT (runS m) initRouteState+  return $ foldl (\a b -> b a) (defaultApp s) (middlewares s)+

@@ -0,0 +1,116 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{- |+Module      :  Network.Wai.Middleware.Routes.Routes+Copyright   :  (c) Anupam Jain 2011+License     :  GNU GPL Version 3 (see the file LICENSE)++Maintainer  :  ajnsit@gmail.com+Stability   :  experimental+Portability :  non-portable (uses ghc extensions)++This package provides typesafe URLs for Wai applications.+-}+module Network.Wai.Middleware.Routes.Routes+    ( -- * Quasi Quoters+      parseRoutes            -- | Parse Routes declared inline+    , parseRoutesFile        -- | Parse routes declared in a file+    , parseRoutesNoCheck     -- | Parse routes declared inline, without checking for overlaps+    , parseRoutesFileNoCheck -- | Parse routes declared in a file, without checking for overlaps++    -- * Template Haskell methods+    , mkRoute++    -- * Dispatch+    , dispatch++    -- * URL rendering+    , showRoute++    -- * Application Handlers+    , Handler++    -- * Generated Datatypes+    , Routable(..)+    , RenderRoute(..)        -- | A `RenderRoute` instance for your site datatype is automatically generated by `mkRoute`+    , Route(..)              -- | The `Route` datatype generated by `mkRoute`++    )+    where++-- Wai+import Network.Wai (Middleware, Application, pathInfo, requestMethod)+import Network.HTTP.Types (StdMethod(GET), parseMethod)++-- Yesod Routes+import Yesod.Routes.Class (Route, RenderRoute(..))+import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)+import Yesod.Routes.TH (mkRenderRouteInstance, mkDispatchClause, ResourceTree(..))++-- Text+import qualified Data.Text as T+import Data.Text (Text)++-- TH+import Language.Haskell.TH.Syntax++-- | Generates all the things needed for efficient routing,+-- including your application's `Route` datatype, and a `RenderRoute` instance+mkRoute :: String -> [ResourceTree String] -> Q [Dec]+mkRoute typName routes = do+  let typ = parseType typName+  inst <- mkRenderRouteInstance typ $ map (fmap parseType) routes+  dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|id|] routes+  return $ InstanceD []+          (ConT ''Routable `AppT` typ)+          [FunD (mkName "dispatcher") [dispatch]]+        : inst++-- | A `Handler` generates an `Application` from the master datatype+type Handler master = master -> Application++-- PRIVATE+runHandler+  :: Handler master+  -> master+  -> master+  -> Maybe (Route master)+  -> (Route master -> Route master)+  -> Handler master+runHandler h _ _ _ _ = h++-- | A `Routable` instance can be used in dispatching.+--   An appropriate instance for your site datatype is+--   automatically generated by `mkRoute`+class Routable master where+  dispatcher+    :: master+    -> master+    -> (Route master -> Route master)+    -> Handler master -- 404 page+    -> (Route master -> Handler master) -- 405 page+    -> Text -- method+    -> [Text]+    -> Handler master++-- | Generates the application middleware from a `Routable` master datatype+dispatch :: Routable master => master -> Middleware+dispatch master def req = app master req+  where+    app = dispatcher master master id def404 def405 (T.pack $ show $ method req) (pathInfo req)+    def404 = const def+    def405 = const $ const def -- TODO: This should ideally NOT pass on handling to the next resource+    method req' = case parseMethod $ requestMethod req' of+      Right m -> m+      Left  _ -> GET++-- | Renders a `Route` as Text+showRoute :: RenderRoute master => Route master -> Text+-- TODO: Verify that intercalate "/" is sufficient and correct for all cases+-- HACK: We add a '/' to the front of the URL (by adding an empty piece at+-- the front of the url [Text]) to make everything relative to the root.+-- This ensures that the links always work.+showRoute = T.intercalate (T.pack "/") . (T.pack "" :) . fst . renderRoute+

@@ -1,7 +1,6 @@ Name:                wai-routes-Version:             0.1-Description:         This package provides typesafe URLs for Wai applications.-Synopsis:            This package provides typesafe URLs for Wai applications.+Version:             0.2+Synopsis:            Typesafe URLs for Wai applications. Homepage:            https://github.com/ajnsit/wai-routes License:             GPL License-file:        LICENSE@@ -11,7 +10,52 @@ Cabal-Version:       >=1.6 stability:           Experimental Category:            Network-Extra-source-files:  README+Extra-source-files:  README, examples/Example.hs+Description:+  Provides easy to use typesafe URLs for Wai Applications.+  .+  Sample usage follows (See examples/Example.hs in the source bundle for the full code) -+  .+  @+    &#123;-&#35; LANGUAGE OverloadedStrings, TypeFamilies &#35;-&#125;+    .+    import Network.Wai+    import Network.Wai.Middleware.Routes+    .+    import Data.IORef+    .+    &#45;&#45; The Site Argument+    data MyRoute = MyRoute (IORef DB)+    .+    &#45;&#45; Generate Routes+    mkRoute "MyRoute" &#91;parseRoutes&#124;+    &#47;             UsersR         GET+    &#47;user&#47;&#35;Int    UserR&#58;+    &#32;&#32;/              UserRootR   GET+    &#32;&#32;/delete        UserDeleteR POST+    &#91;&#124;+    .+    &#45;&#45; Define Handlers+    &#45;&#45; All Users Page+    getUsersR &#58;&#58; Handler MyRoute+    getUsersR (MyRoute dbref) request = ...+    &#45;&#45; Single User Page+    getUserRootR &#58;&#58; Int -> Handler MyRoute+    getUserRootR userid (MyRoute dbref) request = ...+    &#45;&#45; Delete Single User+    postUserDeleteR &#58;&#58; Int -> Handler MyRoute+    postUserDeleteR userid (MyRoute dbref) request = ...+    .+    &#45;&#45; Define Application using RouteM Monad+    myApp = do+    &#32;&#32;db <- liftIO &#36; newIORef mydb+    &#32;&#32;route (MyRoute db)+    &#32;&#32;setDefaultAction $ staticApp $ defaultFileServerSettings &#34;static&#34;+    .+    &#45;&#45; Run the application+    main &#58;&#58; IO ()+    main = toWaiApp myApp >>= run 8080+  @  source-repository head   type:     git@@ -19,16 +63,20 @@  source-repository this   type:     git-  location: http://github.com/ajnsit/wai-routes/tree/v0.1-  tag:      v0.1+  location: http://github.com/ajnsit/wai-routes/tree/v0.2+  tag:      v0.2  Library   hs-source-dirs:    src   Build-Depends:     base >= 3 && < 5-               ,     wai+               ,     wai >= 1.3                ,     path-pieces                ,     text-               ,     http-types+               ,     http-types >= 0.7                ,     template-haskell+               ,     yesod-routes >= 1.1+               ,     mtl   exposed-modules:   Network.Wai.Middleware.Routes+               ,     Network.Wai.Middleware.Routes.Routes+               ,     Network.Wai.Middleware.Routes.Monad