diff --git a/README b/README --- a/README +++ b/README @@ -1,4 +1,4 @@ -Wai Routes (wai-routes-0.2.3) +Wai Routes (wai-routes-0.3.0) ============================== This package provides typesafe URLs for Wai applications. @@ -10,6 +10,8 @@ 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. + - Handlers can abort processing and pass control to the next + application in the wai stack 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. @@ -69,4 +71,5 @@ 0.2.2 : Fixed license information in hs and cabal files 0.2.3 : Implemented a better showRoute function. Added blaze-builder as a dependency 0.2.4 : Put an upper bound on yesod-routes version as 1.2 breaks API compatibility +0.3.0 : yesod-routes 1.2 compatibility. Abstracted request data. Created `runNext` which skips to the next app in the wai stack diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -36,6 +36,7 @@ /user/#Int UserR: / UserRootR GET /delete UserDeleteR GET POST +/skip SkipR GET |] -- Our handlers always produce json @@ -46,12 +47,13 @@ -- Display the possible actions getHomeR :: Handler MyRoute -getHomeR _master _req = return $ responseLBS status200 jsonHeaders jsonOut +getHomeR _master req = return $ responseLBS status200 jsonHeaders jsonOut where jsonOut = encode $ M.fromList ( [("description", [["Simple User database Example"]]) ,("links" ,[["home", showRoute HomeR] ,["users", showRoute UsersR] + ,["skip", showRoute SkipR] ] ) ] :: [(Text, [[Text]])] ) @@ -96,7 +98,7 @@ -- Delete a user: GET getUserDeleteR :: Int -> Handler MyRoute -getUserDeleteR _ _master _req = return $ responseLBS status200 jsonHeaders jsonOut +getUserDeleteR _ _master req = return $ responseLBS status200 jsonHeaders jsonOut where err = ["DELETE","please use POST"]::[Text] jsonOut = encode err @@ -106,6 +108,10 @@ where err = ["DELETE","not implemented"]::[Text] jsonOut = encode err +-- Demonstrate skipping routes +getSkipR :: Handler MyRoute +getSkipR _master = runNext + -- Initial database initdb :: [User] initdb = @@ -113,12 +119,27 @@ , User 2 "Bo Lively" 28 ] +-- A new middleware to catch all skipped routes +data MySkippedRoute = MySkippedRoute + +-- Make MyRoute Routable +mkRoute "MySkippedRoute" [parseRoutes| +/skip SkippedR GET +|] + +getSkippedR :: Handler MySkippedRoute +getSkippedR _req _master = + return $ responseLBS status200 jsonHeaders jsonOut + where err = ["SKIPPED","skipped route"]::[Text] + jsonOut = encode err + -- 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) + route MySkippedRoute defaultAction $ staticApp $ defaultFileServerSettings "static" -- Run the application 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,6 @@ {- | Module : Network.Wai.Middleware.Routes -Copyright : (c) Anupam Jain 2011 +Copyright : (c) Anupam Jain 2013 License : MIT (see the file LICENSE) Maintainer : ajnsit@gmail.com diff --git a/src/Network/Wai/Middleware/Routes/Monad.hs b/src/Network/Wai/Middleware/Routes/Monad.hs --- a/src/Network/Wai/Middleware/Routes/Monad.hs +++ b/src/Network/Wai/Middleware/Routes/Monad.hs @@ -2,7 +2,7 @@ {- | Module : Network.Wai.Middleware.Routes.Monad -Copyright : (c) Anupam Jain 2011 +Copyright : (c) Anupam Jain 2013 License : MIT (see the file LICENSE) Maintainer : ajnsit@gmail.com diff --git a/src/Network/Wai/Middleware/Routes/Routes.hs b/src/Network/Wai/Middleware/Routes/Routes.hs --- a/src/Network/Wai/Middleware/Routes/Routes.hs +++ b/src/Network/Wai/Middleware/Routes/Routes.hs @@ -1,10 +1,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {- | Module : Network.Wai.Middleware.Routes.Routes -Copyright : (c) Anupam Jain 2011 +Copyright : (c) Anupam Jain 2013 License : MIT (see the file LICENSE) Maintainer : ajnsit@gmail.com @@ -26,95 +27,132 @@ -- * Dispatch , routeDispatch - -- * URL rendering + -- * URL rendering and parsing , showRoute + , readRoute -- * Application Handlers , Handler -- * Generated Datatypes - , Routable(..) + , Routable(..) -- | Used internally. However needs to be exported for TH to work. , RenderRoute(..) -- | A `RenderRoute` instance for your site datatype is automatically generated by `mkRoute` + , ParseRoute(..) -- | A `ParseRoute` instance for your site datatype is automatically generated by `mkRoute` + , RouteAttrs(..) -- | A `RouteAttrs` instance for your site datatype is automatically generated by `mkRoute` + , 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 + , runNext -- | Run the next application in the stack ) where +-- Conduit +import Data.Conduit (ResourceT) + -- Wai -import Network.Wai (Middleware, Application, pathInfo, requestMethod) -import Network.HTTP.Types (StdMethod(GET), parseMethod, encodePath, queryTextToQuery) +import Network.Wai (Middleware, Application, pathInfo, requestMethod, requestMethod, Response(ResponseBuilder), Request(..)) +import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText, status405) -- Yesod Routes -import Yesod.Routes.Class (Route, RenderRoute(..)) +import Yesod.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..)) import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType) -import Yesod.Routes.TH (mkRenderRouteInstance, mkDispatchClause, ResourceTree(..)) +import Yesod.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler) -- Text and Bytestring -import qualified Data.Text as T import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Blaze.ByteString.Builder (Builder, toByteString) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Blaze.ByteString.Builder (toByteString, fromByteString) -- TH import Language.Haskell.TH.Syntax -- Convenience import Control.Arrow (second) +import Data.Maybe (fromMaybe) +-- An abstract request +data RequestData = RequestData + { waiReq :: Request + , nextApp :: Application + } + +-- | Run the next application in the stack +runNext :: RequestData -> ResourceT IO Response +runNext req = nextApp req $ waiReq req + +-- Internal data type for convenience +type App = RequestData -> ResourceT IO Response + +-- | A `Handler` generates an App from the master datatype +type Handler master = master -> App + +-- 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 req = nextApp req $ waiReq req + +app405 :: Handler master +app405 _master _req = return $ ResponseBuilder status405 [("Content-Type","text/plain")] $ fromByteString "405 - Method Not Allowed" + -- | Generates all the things needed for efficient routing, --- including your application's `Route` datatype, and a `RenderRoute` instance +-- including your application's `Route` datatype, and +-- `RenderRoute`, `ParseRoute`, and `RouteAttr` instances mkRoute :: String -> [ResourceTree String] -> Q [Dec] mkRoute typName routes = do let typ = parseType typName - inst <- mkRenderRouteInstance typ $ map (fmap parseType) routes - disp <- mkDispatchClause [|runHandler|] [|dispatcher|] [|id|] routes + let resourceTrees = map (fmap parseType) routes + rinst <- mkRenderRouteInstance typ resourceTrees + pinst <- mkParseRouteInstance typ resourceTrees + ainst <- mkRouteAttrsInstance typ resourceTrees + 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 |] + , mdsGetHandler = defaultGetHandler + } routes return $ InstanceD [] (ConT ''Routable `AppT` typ) [FunD (mkName "dispatcher") [disp]] - : inst + : ainst + : pinst + : rinst --- | 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 + :: Handler master + -> master + -> Maybe (Route master) + -> App +runHandler h master _ = h master -- | 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 + dispatcher :: Handler master -- | Generates the application middleware from a `Routable` master datatype routeDispatch :: Routable master => master -> Middleware -routeDispatch 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 +routeDispatch master def req = dispatcher master RequestData{waiReq=req, nextApp=def} -- | Renders a `Route` as Text --- Uses the `encodePath` function from http-types. Also performs utf8 encoding showRoute :: RenderRoute master => Route master -> Text showRoute = uncurry encodePathInfo . second (map $ second Just) . renderRoute where encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery + +-- | Read a route from Text +-- Returns Nothing if Route reading failed. Just route otherwise +readRoute :: ParseRoute master => Text -> Maybe (Route master) +readRoute = parseRoute . second (map (second (fromMaybe "")) . queryToQueryText) . decodePath . encodeUtf8 diff --git a/wai-routes.cabal b/wai-routes.cabal --- a/wai-routes.cabal +++ b/wai-routes.cabal @@ -1,5 +1,5 @@ Name: wai-routes -Version: 0.2.4 +Version: 0.3.0 Synopsis: Typesafe URLs for Wai applications. Homepage: https://github.com/ajnsit/wai-routes License: MIT @@ -63,19 +63,20 @@ source-repository this type: git - location: http://github.com/ajnsit/wai-routes/tree/v0.2.4 - tag: v0.2.4 + location: http://github.com/ajnsit/wai-routes/tree/v0.3.0 + tag: v0.3.0 Library hs-source-dirs: src Build-Depends: base >= 3 && < 5 - , wai >= 1.3 + , wai >= 1.3 && < 1.5 + , conduit >= 0.5 && < 1.1 , path-pieces , text , http-types >= 0.7 , blaze-builder >= 0.2.1.4 && < 0.4 , template-haskell - , yesod-routes >= 1.1 && < 1.2 + , yesod-routes >= 1.2 , mtl exposed-modules: Network.Wai.Middleware.Routes , Network.Wai.Middleware.Routes.Routes