diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -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 + diff --git a/src/Network/Wai/Middleware/Routes.hs b/src/Network/Wai/Middleware/Routes.hs --- a/src/Network/Wai/Middleware/Routes.hs +++ b/src/Network/Wai/Middleware/Routes.hs @@ -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 diff --git a/src/Network/Wai/Middleware/Routes/Monad.hs b/src/Network/Wai/Middleware/Routes/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Routes/Monad.hs @@ -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) + diff --git a/src/Network/Wai/Middleware/Routes/Routes.hs b/src/Network/Wai/Middleware/Routes/Routes.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Routes/Routes.hs @@ -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 + diff --git a/wai-routes.cabal b/wai-routes.cabal --- a/wai-routes.cabal +++ b/wai-routes.cabal @@ -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) - + . + @ + {-# LANGUAGE OverloadedStrings, TypeFamilies #-} + . + import Network.Wai + import Network.Wai.Middleware.Routes + . + import Data.IORef + . + -- The Site Argument + data MyRoute = MyRoute (IORef DB) + . + -- Generate Routes + mkRoute "MyRoute" [parseRoutes| + / UsersR GET + /user/#Int UserR: + / UserRootR GET + /delete UserDeleteR POST + [| + . + -- 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 = 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