wai-routes 0.6.2 → 0.7.0
raw patch · 7 files changed
+200/−275 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Network.Wai.Middleware.Routes.Handler: instance (Monad m, Functor m) => Applicative (HandlerMI master m)
- Network.Wai.Middleware.Routes.Handler: instance Functor m => Functor (HandlerMI master m)
- Network.Wai.Middleware.Routes.Handler: instance Monad m => Monad (HandlerMI master m)
- Network.Wai.Middleware.Routes.Handler: instance Monad m => MonadState (HandlerState master) (HandlerMI master m)
- Network.Wai.Middleware.Routes.Handler: instance MonadIO m => MonadIO (HandlerMI master m)
- Network.Wai.Middleware.Routes.Handler: instance MonadTrans (HandlerMI master)
+ Network.Wai.Middleware.Routes: maybeRootRoute :: HandlerM sub master (Maybe (Route master))
+ Network.Wai.Middleware.Routes: mkRouteData :: String -> [ResourceTree String] -> Q [Dec]
+ Network.Wai.Middleware.Routes: mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]
+ Network.Wai.Middleware.Routes: mkRouteSubDispatch :: [ResourceTree a] -> Q Exp
+ Network.Wai.Middleware.Routes: rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text)
+ Network.Wai.Middleware.Routes: type HandlerS sub master = Env sub master -> App sub
+ Network.Wai.Middleware.Routes.Handler: instance (Monad m, Functor m) => Applicative (HandlerMI sub master m)
+ Network.Wai.Middleware.Routes.Handler: instance Functor m => Functor (HandlerMI sub master m)
+ Network.Wai.Middleware.Routes.Handler: instance Monad m => Monad (HandlerMI sub master m)
+ Network.Wai.Middleware.Routes.Handler: instance Monad m => MonadState (HandlerState sub master) (HandlerMI sub master m)
+ Network.Wai.Middleware.Routes.Handler: instance MonadIO m => MonadIO (HandlerMI sub master m)
+ Network.Wai.Middleware.Routes.Handler: instance MonadTrans (HandlerMI sub master)
+ Network.Wai.Middleware.Routes.Handler: maybeRootRoute :: HandlerM sub master (Maybe (Route master))
+ Network.Wai.Middleware.Routes.Handler: rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text)
+ Network.Wai.Middleware.Routes.Routes: Env :: master -> sub -> (Route sub -> Route master) -> Env sub master
+ Network.Wai.Middleware.Routes.Routes: data Env sub master
+ Network.Wai.Middleware.Routes.Routes: envMaster :: Env sub master -> master
+ Network.Wai.Middleware.Routes.Routes: envSub :: Env sub master -> sub
+ Network.Wai.Middleware.Routes.Routes: envToMaster :: Env sub master -> Route sub -> Route master
+ Network.Wai.Middleware.Routes.Routes: mkRouteData :: String -> [ResourceTree String] -> Q [Dec]
+ Network.Wai.Middleware.Routes.Routes: mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]
+ Network.Wai.Middleware.Routes.Routes: mkRouteSubDispatch :: [ResourceTree a] -> Q Exp
+ Network.Wai.Middleware.Routes.Routes: type HandlerS sub master = Env sub master -> App sub
- Network.Wai.Middleware.Routes: class Routable master
+ Network.Wai.Middleware.Routes: class Routable sub master
- Network.Wai.Middleware.Routes: dispatcher :: Routable master => Handler master
+ Network.Wai.Middleware.Routes: dispatcher :: Routable sub master => HandlerS sub master
- Network.Wai.Middleware.Routes: header :: HeaderName -> ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes: header :: HeaderName -> ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: html :: ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes: html :: ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: json :: ToJSON a => a -> HandlerM master ()
+ Network.Wai.Middleware.Routes: json :: ToJSON a => a -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: master :: HandlerM master master
+ Network.Wai.Middleware.Routes: master :: HandlerM sub master master
- Network.Wai.Middleware.Routes: maybeRoute :: HandlerM master (Maybe (Route master))
+ Network.Wai.Middleware.Routes: maybeRoute :: HandlerM sub master (Maybe (Route sub))
- Network.Wai.Middleware.Routes: next :: HandlerM master ()
+ Network.Wai.Middleware.Routes: next :: HandlerM sub master ()
- Network.Wai.Middleware.Routes: raw :: ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes: raw :: ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: request :: HandlerM master Request
+ Network.Wai.Middleware.Routes: request :: HandlerM sub master Request
- Network.Wai.Middleware.Routes: route :: Routable master => master -> RouteM ()
+ Network.Wai.Middleware.Routes: route :: Routable master master => master -> RouteM ()
- Network.Wai.Middleware.Routes: routeAttrSet :: RouteAttrs master => HandlerM master (Set Text)
+ Network.Wai.Middleware.Routes: routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text)
- Network.Wai.Middleware.Routes: routeDispatch :: Routable master => master -> Middleware
+ Network.Wai.Middleware.Routes: routeDispatch :: Routable master master => master -> Middleware
- Network.Wai.Middleware.Routes: runHandlerM :: HandlerM master () -> Handler master
+ Network.Wai.Middleware.Routes: runHandlerM :: HandlerM sub master () -> HandlerS sub master
- Network.Wai.Middleware.Routes: status :: Status -> HandlerM master ()
+ Network.Wai.Middleware.Routes: status :: Status -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: text :: Text -> HandlerM master ()
+ Network.Wai.Middleware.Routes: text :: Text -> HandlerM sub master ()
- Network.Wai.Middleware.Routes: type Handler master = master -> App master
+ Network.Wai.Middleware.Routes: type Handler master = HandlerS master master
- Network.Wai.Middleware.Routes: type HandlerM master a = HandlerMI master IO a
+ Network.Wai.Middleware.Routes: type HandlerM sub master a = HandlerMI sub master IO a
- Network.Wai.Middleware.Routes.Handler: header :: HeaderName -> ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: header :: HeaderName -> ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: html :: ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: html :: ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: json :: ToJSON a => a -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: json :: ToJSON a => a -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: master :: HandlerM master master
+ Network.Wai.Middleware.Routes.Handler: master :: HandlerM sub master master
- Network.Wai.Middleware.Routes.Handler: maybeRoute :: HandlerM master (Maybe (Route master))
+ Network.Wai.Middleware.Routes.Handler: maybeRoute :: HandlerM sub master (Maybe (Route sub))
- Network.Wai.Middleware.Routes.Handler: next :: HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: next :: HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: raw :: ByteString -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: raw :: ByteString -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: request :: HandlerM master Request
+ Network.Wai.Middleware.Routes.Handler: request :: HandlerM sub master Request
- Network.Wai.Middleware.Routes.Handler: routeAttrSet :: RouteAttrs master => HandlerM master (Set Text)
+ Network.Wai.Middleware.Routes.Handler: routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text)
- Network.Wai.Middleware.Routes.Handler: runHandlerM :: HandlerM master () -> Handler master
+ Network.Wai.Middleware.Routes.Handler: runHandlerM :: HandlerM sub master () -> HandlerS sub master
- Network.Wai.Middleware.Routes.Handler: status :: Status -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: status :: Status -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: text :: Text -> HandlerM master ()
+ Network.Wai.Middleware.Routes.Handler: text :: Text -> HandlerM sub master ()
- Network.Wai.Middleware.Routes.Handler: type HandlerM master a = HandlerMI master IO a
+ Network.Wai.Middleware.Routes.Handler: type HandlerM sub master a = HandlerMI sub master IO a
- Network.Wai.Middleware.Routes.Monad: route :: Routable master => master -> RouteM ()
+ Network.Wai.Middleware.Routes.Monad: route :: Routable master master => master -> RouteM ()
- Network.Wai.Middleware.Routes.Routes: class Routable master
+ Network.Wai.Middleware.Routes.Routes: class Routable sub master
- Network.Wai.Middleware.Routes.Routes: dispatcher :: Routable master => Handler master
+ Network.Wai.Middleware.Routes.Routes: dispatcher :: Routable sub master => HandlerS sub master
- Network.Wai.Middleware.Routes.Routes: routeDispatch :: Routable master => master -> Middleware
+ Network.Wai.Middleware.Routes.Routes: routeDispatch :: Routable master master => master -> Middleware
- Network.Wai.Middleware.Routes.Routes: type Handler master = master -> App master
+ Network.Wai.Middleware.Routes.Routes: type Handler master = HandlerS master master
Files
- README.md +3/−2
- examples/Example.hs +0/−151
- src/Network/Wai/Middleware/Routes.hs +6/−0
- src/Network/Wai/Middleware/Routes/Handler.hs +45/−25
- src/Network/Wai/Middleware/Routes/Monad.hs +1/−1
- src/Network/Wai/Middleware/Routes/Routes.hs +140/−48
- wai-routes.cabal +5/−48
README.md view
@@ -1,4 +1,4 @@-Wai Routes (wai-routes-0.6.2)+Wai Routes (wai-routes-0.7.0) ==================================== [](https://travis-ci.org/ajnsit/wai-routes)@@ -8,6 +8,7 @@ Features: - Automatic generation of Route boilerplate using TH - Easy Nested Routes+ - Subsites - General purpose Route Attributes/Annotations - Sitewide Master datatype which is passed to all handlers and can be used for persistent data (like DB connections)@@ -26,7 +27,6 @@ The following features are planned for later releases - -- Subsites - Development mode - Keter and Heroku support - Scaffolding@@ -101,4 +101,5 @@ * 0.6.0 : Removed dependency on yesod-routes. Updated code to compile with wai-3 and ghc-7.8, ghc-7.10 * 0.6.1 : Fixed cabal and travis files * 0.6.2 : Added 'maybeRoute' and 'routeAttrSet', to get information about the currently executing route+* 0.7.0 : Subsites support added
− examples/Example.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns #-}-module Main where--import Network.Wai-import Network.Wai.Middleware.Routes-import Network.Wai.Middleware.Routes.ContentTypes-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 hiding (json)-import Data.IORef-import qualified Data.Map as M-import Control.Monad.Trans-import Network.Wai.Middleware.RequestLogger---- 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 !hello GET-/users UsersR GET-/user/#Int UserR:- / UserRootR GET- /delete UserDeleteR GET POST-/skip/*[Text] SkipR GET-|]----- Handlers---- Util: Fetch the database-getDB :: HandlerM MyRoute DB-getDB = do- MyRoute dbref <- master- liftIO $ readIORef dbref---- Display the possible actions-getHomeR :: Handler MyRoute-getHomeR = runHandlerM $ do- mroute <- maybeRoute- attrs <- routeAttrSet- liftIO $ putStrLn $ show mroute- liftIO $ putStrLn $ show attrs- json $ M.fromList (- [("description", [["Simple User database Example"]])- ,("links"- ,[["home", showRoute HomeR]- ,["users", showRoute UsersR]- ,["skip", showRoute $ SkipR []]- ]- )- ] :: [(Text, [[Text]])] )---- Display all the users-getUsersR :: Handler MyRoute-getUsersR = runHandlerM $ do- db <- getDB- let dblinks = map linkify db- json $ M.fromList (- [("description", [["Users List"]])- ,("links", dblinks)] :: [(Text, [[Text]])] )- where- linkify user = [userName user, showRoute $ UserR (userId user) UserRootR]---- Display a single user-getUserRootR :: Int -> Handler MyRoute-getUserRootR i = runHandlerM $ do- db <- getDB- case ulookup i db of- Nothing -> json ("ERROR: User not found" :: Text)- Just user -> do- json $ 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]])] )- where- ulookup _ [] = Nothing- ulookup ui (u:us) = if userId u == ui then Just u else ulookup ui us---- Delete a user: GET-getUserDeleteR :: Int -> Handler MyRoute-getUserDeleteR _ = runHandlerM $ json (["DELETE","please use POST"]::[Text])---- Delete a user: POST-postUserDeleteR :: Int -> Handler MyRoute-postUserDeleteR _ = runHandlerM $ json (["DELETE","not implemented"]::[Text])---- Demonstrate skipping routes-getSkipR :: [Text] -> Handler MyRoute-getSkipR _ = runHandlerM $ next >> return ()---- Initial database-initdb :: [User]-initdb =- [ User 1 "Anon Amos" 23- , User 2 "Bo Lively" 28- ]---- A new middleware to catch all skipped routes-data MySkippedRoute = MySkippedRoute---- Catch all 'skipped` routes-mkRoute "MySkippedRoute" [parseRoutes|-/skip/*[Text] SkippedR GET-|]--getSkippedR :: [Text] -> Handler MySkippedRoute-getSkippedR rest = runHandlerM $ json $ ["SKIPPED ROUTE: "] ++ rest---- The application that uses our route--- NOTE: We use the Route Monad to simplify routing-application :: RouteM ()-application = do- db <- liftIO $ newIORef initdb- middleware logStdoutDev- route (MyRoute db)- route MySkippedRoute- defaultAction $ staticApp $ defaultFileServerSettings "static"---- Run the application-main :: IO ()-main = do- putStrLn "Starting server on port 8080"- toWaiApp application >>= run 8080-
src/Network/Wai/Middleware/Routes.hs view
@@ -18,6 +18,9 @@ -- * Template Haskell methods , mkRoute+ , mkRouteData+ , mkRouteDispatch+ , mkRouteSubDispatch -- * Dispatch , routeDispatch@@ -28,6 +31,7 @@ -- * Application Handlers , Handler+ , HandlerS -- * Generated Datatypes , Routable(..) -- | Used internally. However needs to be exported for TH to work.@@ -52,8 +56,10 @@ , HandlerM() , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data+ , maybeRootRoute -- | Access the current route for root route , maybeRoute -- | Access the current route , routeAttrSet -- | Access the current route attributes as a set+ , rootRouteAttrSet -- | Access the current root route attributes as a set , master -- | Access the master datatype , header -- | Add a header to the response , status -- | Set the response status
src/Network/Wai/Middleware/Routes/Handler.hs view
@@ -15,7 +15,9 @@ , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data , routeAttrSet -- | Access the route attribute list+ , rootRouteAttrSet -- | Access the route attribute list for the root route , maybeRoute -- | Access the route data+ , maybeRootRoute -- | Access the root route data , master -- | Access the master datatype , header -- | Add a header to the response , status -- | Set the response status@@ -33,7 +35,7 @@ import Control.Applicative (Applicative) -import Network.Wai.Middleware.Routes.Routes (RequestData, Handler, waiReq, currentRoute, runNext, ResponseHandler)+import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler) import Network.Wai.Middleware.Routes.Class (Route, RouteAttrs(..)) import Network.Wai.Middleware.Routes.ContentTypes (contentType, typeHtml, typeJson, typePlain) @@ -58,102 +60,120 @@ -- | The internal implementation of the HandlerM monad -- TODO: Should change this to StateT over ReaderT (but performance may suffer)-newtype HandlerMI master m a = H { extractH :: StateT (HandlerState master) m a }- deriving (Applicative, Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState master))+newtype HandlerMI sub master m a = H { extractH :: StateT (HandlerState sub master) m a }+ deriving (Applicative, Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState sub master)) -- | The HandlerM Monad-type HandlerM master a = HandlerMI master IO a+type HandlerM sub master a = HandlerMI sub master IO a -- | The state kept in a HandlerM Monad-data HandlerState master = HandlerState+data HandlerState sub master = HandlerState { getMaster :: master- , getRequestData :: RequestData master+ , getRequestData :: RequestData sub , respHeaders :: [(HeaderName, ByteString)] , respStatus :: Status , respBody :: BL.ByteString , respResp :: Maybe ResponseHandler+ , getSub :: sub+ , toMasterRoute :: Route sub -> Route master } -- | "Run" HandlerM, resulting in a Handler-runHandlerM :: HandlerM master () -> Handler master-runHandlerM h m req hh = do- (_, state) <- runStateT (extractH h) (HandlerState m req [] status200 "" Nothing)+runHandlerM :: HandlerM sub master () -> HandlerS sub master+runHandlerM h env req hh = do+ (_, state) <- runStateT (extractH h) (HandlerState (envMaster env) req [] status200 "" Nothing (envSub env) (envToMaster env)) case respResp state of Nothing -> hh $ toResp state Just resp -> resp hh -toResp :: HandlerState master -> Response+toResp :: HandlerState sub master -> Response toResp hs = responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs) -- | Get the master-master :: HandlerM master master+master :: HandlerM sub master master master = liftM getMaster get +-- | Get the sub+sub :: HandlerM sub master sub+sub = liftM getSub get+ -- | Get the request-request :: HandlerM master Request+request :: HandlerM sub master Request request = liftM (waiReq . getRequestData) get -- | Get the current route-maybeRoute :: HandlerM master (Maybe (Route master))+maybeRoute :: HandlerM sub master (Maybe (Route sub)) maybeRoute = liftM (currentRoute . getRequestData) get +-- | Get the current root route+maybeRootRoute :: HandlerM sub master (Maybe (Route master))+maybeRootRoute = do+ s <- get+ return $ fmap (toMasterRoute s) $ currentRoute $ getRequestData s+ -- | Get the current route attributes-routeAttrSet :: RouteAttrs master => HandlerM master (Set Text)+routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text) routeAttrSet = liftM (S.map T.fromStrict . maybe S.empty routeAttrs . currentRoute . getRequestData) get +-- | Get the attributes for the current root route+rootRouteAttrSet :: RouteAttrs master => HandlerM sub master (Set Text)+rootRouteAttrSet = do+ s <- get+ return $ S.map T.fromStrict $ maybe S.empty (routeAttrs . toMasterRoute s) $ currentRoute $ getRequestData s+ -- | Add a header to the application response -- TODO: Differentiate between setting and adding headers-header :: HeaderName -> ByteString -> HandlerM master ()+header :: HeaderName -> ByteString -> HandlerM sub master () header h s = modify $ addHeader h s where- addHeader :: HeaderName -> ByteString -> HandlerState master -> HandlerState master+ addHeader :: HeaderName -> ByteString -> HandlerState sub master -> HandlerState sub master addHeader h b s@(HandlerState {respHeaders=hs}) = s {respHeaders=(h,b):hs} -- | Set the response status-status :: Status -> HandlerM master ()+status :: Status -> HandlerM sub master () status s = modify $ setStatus s where- setStatus :: Status -> HandlerState master -> HandlerState master+ setStatus :: Status -> HandlerState sub master -> HandlerState sub master setStatus s st = st{respStatus=s} -- | Set the response body -- TODO: Add functions to append to body, and also to flush body contents-raw :: BL.ByteString -> HandlerM master ()+raw :: BL.ByteString -> HandlerM sub master () raw s = modify $ setBody s where- setBody :: BL.ByteString -> HandlerState master -> HandlerState master+ setBody :: BL.ByteString -> HandlerState sub master -> HandlerState sub master setBody s st = st{respBody=s} -- Standard response bodies -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" -- header to \"application/json\".-json :: ToJSON a => a -> HandlerM master ()+json :: ToJSON a => a -> HandlerM sub master () json a = do header contentType typeJson raw $ A.encode a -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" -- header to \"text/plain\".-text :: Text -> HandlerM master ()+text :: Text -> HandlerM sub master () text t = do header contentType typePlain raw $ encodeUtf8 t -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" -- header to \"text/html\".-html :: BL.ByteString -> HandlerM master ()+html :: BL.ByteString -> HandlerM sub master () html s = do header contentType typeHtml raw s -- | Run the next application-next :: HandlerM master ()+next :: HandlerM sub master () next = do s <- get let resp = runNext (getRequestData s) modify $ setResp resp where- setResp :: ResponseHandler -> HandlerState master -> HandlerState master+ setResp :: ResponseHandler -> HandlerState sub master -> HandlerState sub master setResp r st = st{respResp=Just r}
src/Network/Wai/Middleware/Routes/Monad.hs view
@@ -59,7 +59,7 @@ -- | Add a route to the application. -- Routes are ordered so the one declared earlier is matched first.-route :: (Routable master) => master -> RouteM ()+route :: (Routable master master) => master -> RouteM () route = middleware . routeDispatch -- | Set the default action of the Application.
src/Network/Wai/Middleware/Routes/Routes.hs view
@@ -23,6 +23,9 @@ -- * Template Haskell methods , mkRoute+ , mkRouteData+ , mkRouteDispatch+ , mkRouteSubDispatch -- * Dispatch , routeDispatch@@ -33,6 +36,7 @@ -- * Application Handlers , Handler+ , HandlerS -- * As of Wai 3, Application datatype now follows continuation passing style -- A `ResponseHandler` represents a continuation passed to the application@@ -45,6 +49,7 @@ , RouteAttrs(..) -- | A `RouteAttrs` instance for your site datatype is automatically generated by `mkRoute` -- * Accessing Request Data+ , Env(..) , RequestData -- | An abstract representation of the request data. You can get the wai request object by using `waiReq` , waiReq -- | Extract the wai `Request` object from `RequestData` , nextApp -- | Extract the next Application in the stack@@ -55,8 +60,8 @@ where -- Wai-import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..), responseBuilder)-import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText, status405)+import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..))+import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText) -- Network.Wai.Middleware.Routes import Network.Wai.Middleware.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))@@ -64,9 +69,10 @@ import Network.Wai.Middleware.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler) -- Text and Bytestring+import Data.ByteString (ByteString) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Blaze.ByteString.Builder (toByteString, fromByteString)+import Blaze.ByteString.Builder (toByteString) -- TH import Language.Haskell.TH.Syntax@@ -75,9 +81,6 @@ import Control.Arrow (second) import Data.Maybe (fromMaybe) --- Common ContentTypes-import Network.Wai.Middleware.Routes.ContentTypes- -- An abstract request data RequestData master = RequestData { waiReq :: Request@@ -88,72 +91,106 @@ -- AJ: Experimental type ResponseHandler = (Response -> IO ResponseReceived) -> IO ResponseReceived +-- Wai uses Application :: Wai.Request -> ResponseHandler+-- However, instead of Request, we use RequestData which has more information type App master = RequestData master -> ResponseHandler +data Env sub master = Env+ { envMaster :: master+ , envSub :: sub+ , envToMaster :: Route sub -> Route master+ }+ -- | Run the next application in the stack runNext :: App master runNext req = nextApp req $ waiReq req -- | A `Handler` generates an App from the master datatype-type Handler master = master -> App master---- Baked in applications that handle 404 and 405 errors--- TODO: Inspect the request to figure out acceptable output formats--- Currently we assume text/plain is acceptable-app404 :: Handler master-app404 _master = runNext--app405 :: Handler master-app405 _master _req h = h $ responseBuilder status405 [(contentType, typePlain)] $ fromByteString "405 - Method Not Allowed"+type Handler master = HandlerS master master+type HandlerS sub master = Env sub master -> App sub --- | Generates all the things needed for efficient routing,--- including your application's `Route` datatype, and--- `RenderRoute`, `ParseRoute`, and `RouteAttr` instances-mkRoute :: String -> [ResourceTree String] -> Q [Dec]-mkRoute typName routes = do+-- | Generates everything except `Routable` instance and dispatch function+mkRouteData :: String -> [ResourceTree String] -> Q [Dec]+mkRouteData typName routes = do let typ = parseType typName+ let rname = mkName $ "resources" ++ typName let resourceTrees = map (fmap parseType) routes+ eres <- lift routes+ let resourcesDec =+ [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+ , FunD rname [Clause [] (NormalB eres) []]+ ] rinst <- mkRenderRouteInstance typ resourceTrees pinst <- mkParseRouteInstance typ resourceTrees ainst <- mkRouteAttrsInstance typ resourceTrees+ return $ concat [ [ainst]+ , [pinst]+ , resourcesDec+ , rinst+ ]++mkRouteSubDispatch :: [ResourceTree a] -> Q Exp+mkRouteSubDispatch routes = do disp <- mkDispatchClause MkDispatchSettings- { mdsRunHandler = [| runHandler |]- -- We don't use subsites- , mdsSubDispatcher = [| undefined |]- , mdsGetPathInfo = [| pathInfo . waiReq |]- , mdsMethod = [| requestMethod . waiReq |]- -- We don't use subsites- , mdsSetPathInfo = [| undefined |]- , mds404 = [| app404 |]- , mds405 = [| app405 |]+ { mdsRunHandler = [| runHandler |]+ , mdsSubDispatcher = [| subDispatcher |]+ , mdsGetPathInfo = [| getPathInfo |]+ , mdsMethod = [| getReqMethod |]+ , mdsSetPathInfo = [| setPathInfo |]+ , mds404 = [| app404 |]+ , mds405 = [| app405 |] , mdsGetHandler = defaultGetHandler } routes- return $ InstanceD []- (ConT ''Routable `AppT` typ)- [FunD (mkName "dispatcher") [disp]]- : ainst- : pinst- : rinst+ inner <- newName "inner"+ let innerFun = FunD inner [disp]+ helper <- newName "helper"+ let fun = FunD helper+ [ Clause+ []+ (NormalB $ VarE inner)+ [innerFun]+ ]+ return $ LetE [fun] (VarE helper) +-- | Generates a 'Routable' instance and dispatch function+mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]+mkRouteDispatch typName routes = do+ let typ = parseType typName+ disp <- mkDispatchClause MkDispatchSettings+ { mdsRunHandler = [| runHandler |]+ , mdsSubDispatcher = [| subDispatcher |]+ , mdsGetPathInfo = [| getPathInfo |]+ , mdsMethod = [| getReqMethod |]+ , mdsSetPathInfo = [| setPathInfo |]+ , mds404 = [| app404 |]+ , mds405 = [| app405 |]+ , mdsGetHandler = defaultGetHandler+ } routes+ return [InstanceD []+ (ConT ''Routable `AppT` typ `AppT` typ)+ [FunD (mkName "dispatcher") [disp]]] --- PRIVATE-runHandler- :: Handler master- -> master- -> Maybe (Route master)- -> App master-runHandler h master route reqdata = h master reqdata{currentRoute=route}+-- | Generates all the things needed for efficient routing,+-- including your application's `Route` datatype, and+-- `RenderRoute`, `ParseRoute`, and `RouteAttr` instances, and+-- `Routable` instance+mkRoute :: String -> [ResourceTree String] -> Q [Dec]+mkRoute typName routes = do+ dat <- mkRouteData typName routes+ disp <- mkRouteDispatch typName routes+ return (disp++dat) -- | 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 :: Handler master+-- automatically generated by `mkRoute`.+class Routable sub master where+ dispatcher :: HandlerS sub master -- | Generates the application middleware from a `Routable` master datatype-routeDispatch :: Routable master => master -> Middleware+routeDispatch :: Routable master master => master -> Middleware+-- Env master master is converted to Env sub master by subDispatcher -- Route information is filled in by runHandler-routeDispatch master def req = dispatcher master RequestData{waiReq=req, nextApp=def, currentRoute=Nothing}+routeDispatch master def req = dispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing} -- | Renders a `Route` as Text showRoute :: RenderRoute master => Route master -> Text@@ -169,3 +206,58 @@ readRoute :: ParseRoute master => Text -> Maybe (Route master) readRoute = parseRoute . second (map (second (fromMaybe "")) . queryToQueryText) . decodePath . encodeUtf8 +-- PRIVATE++-- Get the request method from a RequestData+getReqMethod :: RequestData master -> ByteString+getReqMethod = requestMethod . waiReq++-- Get the path info from a RequestData+getPathInfo :: RequestData master -> [Text]+getPathInfo = pathInfo . waiReq++-- Set the path info in a RequestData+setPathInfo :: [Text] -> RequestData master -> RequestData master+setPathInfo p reqData = reqData { waiReq = (waiReq reqData){pathInfo=p} }++-- Baked in applications that handle 404 and 405 errors+-- On no matching route, skip to next application+app404 :: HandlerS sub master+app404 _master = runNext++-- On matching route, but no matching http method, skip to next application+-- This allows a later route to handle methods not implemented by the previous routes+app405 :: HandlerS sub master+app405 _master = runNext++-- Run a route handler function+runHandler+ :: HandlerS sub master+ -> Env sub master+ -> Maybe (Route sub)+ -> App sub+runHandler h env route reqdata = h env reqdata{currentRoute=route}++-- Run a route subsite handler function+subDispatcher+ :: Routable sub master+ => (HandlerS sub master -> Env sub master -> Maybe (Route sub) -> App sub)+ -> (master -> sub)+ -> (Route sub -> Route master)+ -> Env master master+ -> App master+subDispatcher _runhandler getSub toMasterRoute env reqData = dispatcher env' reqData'+ where+ env' = _envToSub getSub toMasterRoute env+ reqData' = reqData{currentRoute=Nothing}+ qq (k,mv) = (decodeUtf8 k, maybe "" decodeUtf8 mv)+ req = waiReq reqData++_masterToEnv :: master -> Env master master+_masterToEnv master = Env master master id++_envToSub :: (master -> sub) -> (Route sub -> Route master) -> Env master master -> Env sub master+_envToSub getSub toMasterRoute env = Env master sub toMasterRoute+ where+ master = envMaster env+ sub = getSub master
wai-routes.cabal view
@@ -1,5 +1,5 @@ name : wai-routes-version : 0.6.2+version : 0.7.0 cabal-version : >=1.18 build-type : Simple license : MIT@@ -8,54 +8,11 @@ stability : Experimental homepage : https://github.com/ajnsit/wai-routes synopsis : Typesafe URLs for Wai applications.-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- @+description : Provides easy to use typesafe URLs for Wai Applications. See README for more information. Also see examples/ directory for usage examples. category : Network author : Anupam Jain data-dir : ""-extra-source-files : README.md examples/Example.hs+extra-source-files : README.md source-repository head type : git@@ -63,8 +20,8 @@ source-repository this type : git- location : http://github.com/ajnsit/wai-routes/tree/v0.6.2- tag : v0.6.2+ location : http://github.com/ajnsit/wai-routes/tree/v0.7.0+ tag : v0.7.0 library build-depends: base >= 4.7 && < 4.9