packages feed

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 view
@@ -1,4 +1,4 @@-Wai Routes (wai-routes-0.6.2)+Wai Routes (wai-routes-0.7.0) ====================================  [![Build Status](https://travis-ci.org/ajnsit/wai-routes.png)](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) --             .-             @-             &#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-             &#124;&#93;-             .-             &#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-             @+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