diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,26 +1,26 @@ -[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.7.3-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Coverage Status](https://coveralls.io/repos/ajnsit/wai-routes/badge.svg?branch=master&service=github)](https://coveralls.io/github/ajnsit/wai-routes?branch=master) +[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.8.0-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Coverage Status](https://coveralls.io/repos/ajnsit/wai-routes/badge.svg?branch=master&service=github)](https://coveralls.io/github/ajnsit/wai-routes?branch=master) ==================================== -This package provides typesafe URLs for Wai applications. +Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. +Wai-routes is based on the Haskell [Web Application Interface](http://hackage.haskell.org/package/wai) and uses it for most of the heavy lifting. It also provides a convenient but thin veneer over most of the wai API so it is unnecessary to directly use raw wai APIs when building web apps. + +Much of Wai-route's typesafe URL functionality was pulled from the corresponding features in [Yesod](http://www.yesodweb.com/), and indeed the underlying aim of wai-routes 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 - - 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) - - RouteM monad that makes it easy to compose an application - with multiple routes and middleware. - - HandlerM monad that makes it easy to build a Handler - with access to Request data and Master datatype - - Handlers can abort processing and pass control to the next - application in the wai stack - - Streaming responses +Wai-routes adds the following features on top of wai - -The aim is to provide a similar level of typesafe URL functionality to Wai applications as is available to Yesod applications. + - Typesafe URLs, including automatic boilerplate generation using TH. Including features such as - + - Nested Routes + - Subsites + - Route Annotations + - Sitewide Master data which is passed to all handlers and can be used for persistent data (like DB connections) + - Easy to use Handler Monad which allows direct access to request and master data + - Easy composition of multiple routes and middleware to construct an application + - Ability to abort processing and pass control to the next application in the wai stack + - Streaming responses Performance @@ -68,7 +68,8 @@ The following features are planned for later releases - -- Add support for raw network responses (see http://hackage.haskell.org/package/wai-3.0.3.0/docs/Network-Wai.html#v:responseRaw) +- Support for raw network responses (see http://hackage.haskell.org/package/wai-3.0.3.0/docs/Network-Wai.html#v:responseRaw) +- Seamless websocket support - Development mode - Keter and Heroku support - Scaffolding @@ -79,6 +80,7 @@ Changelog ========= +* 0.8.0 : Replaced 'show/renderRoute' with 'show/renderRouteSub' and 'show/renderRouteMaster'. Added functions to access request headers (reqHeader/s), send a part of a file (filepart). Auto infer mime-types when sending files. Added cookie handling functions (get/setCookie/s). Added 'sub' to allow access to subsite datatype. * 0.7.3 : Added 'stream' to stream responses. Added 'asContent', 'css', and 'javascript' functions. * 0.7.2 : Added 'file' to send a raw file directly, 'rawBody' and 'jsonBody' to consume request body. Refactored RouteM to add 'catchAll' and 'waiApp'. * 0.7.1 : Added 'showRouteQuery', renamed 'text' to 'plain', 'html' now accepts Text instead of ByteString 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 @@ -26,9 +26,12 @@ , routeDispatch -- * URL rendering and parsing - , showRoute - , showRouteQuery - , readRoute + , showRouteMaster + , showRouteQueryMaster + , readRouteMaster + , showRouteSub + , showRouteQuerySub + , readRouteSub -- * Application Handlers , Handler @@ -59,14 +62,20 @@ , HandlerM() , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data + , reqHeader -- | Get a particular request header (case insensitive) + , reqHeaders -- | Get all request headers (case insensitive) , 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 + , sub -- | Access the sub datatype + , rawBody -- | Consume and return the request body as a lazy bytestring + , jsonBody -- | Consume and return the request body as JSON , header -- | Add a header to the response , status -- | Set the response status , file -- | Send a file as response + , filepart -- | Send a part of a file as response , stream -- | Stream a response , raw -- | Set the raw response body , json -- | Set the json response body @@ -76,8 +85,9 @@ , javascript -- | Set the javascript response body , asContent -- | Set the contentType and a 'Text' body , next -- | Run the next application in the stack - , rawBody -- | Consume and return the request body as a lazy bytestring - , jsonBody -- | Consume and return the request body as JSON + , setCookie -- | Add a cookie to the response + , getCookie -- | Get a cookie from the request + , getCookies -- | Get all cookies from the request ) where diff --git a/src/Network/Wai/Middleware/Routes/ContentTypes.hs b/src/Network/Wai/Middleware/Routes/ContentTypes.hs --- a/src/Network/Wai/Middleware/Routes/ContentTypes.hs +++ b/src/Network/Wai/Middleware/Routes/ContentTypes.hs @@ -13,7 +13,7 @@ -} module Network.Wai.Middleware.Routes.ContentTypes ( -- * Construct content Type - contentType + contentType, contentTypeFromFile -- * Various common content types , typeHtml, typePlain, typeJson , typeXml, typeAtom, typeRss @@ -23,9 +23,16 @@ ) where +import qualified Data.Text as T (pack) import Data.ByteString (ByteString) import Data.ByteString.Char8 () -- Import IsString instance for ByteString import Network.HTTP.Types.Header (HeaderName()) +import Network.Mime (defaultMimeLookup) +import System.FilePath (takeFileName) + +-- | Construct an appropriate content type header from a file name +contentTypeFromFile :: FilePath -> ByteString +contentTypeFromFile = defaultMimeLookup . T.pack . takeFileName -- | Creates a content type header -- Ready to be passed to `responseLBS` diff --git a/src/Network/Wai/Middleware/Routes/Handler.hs b/src/Network/Wai/Middleware/Routes/Handler.hs --- a/src/Network/Wai/Middleware/Routes/Handler.hs +++ b/src/Network/Wai/Middleware/Routes/Handler.hs @@ -14,14 +14,26 @@ ( HandlerM() -- | A Monad that makes it easier to build a Handler , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data + , reqHeader -- | Get a particular request header (case insensitive) + , reqHeaders -- | Get all request headers (case insensitive) , 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 + , showRouteMaster -- | Get the route rendering function for the master site + , showRouteSub -- | Get the route rendering function for the subsite + , showRouteQueryMaster -- | Get the route + query params rendering function for the master site + , showRouteQuerySub -- | Get the route + query params rendering function for the subsite + , readRouteMaster -- | Get the route parsing function for the master site + , readRouteSub -- | Get the route parsing function for the subsite , master -- | Access the master datatype + , sub -- | Access the sub datatype + , rawBody -- | Consume and return the request body as a lazy bytestring + , jsonBody -- | Consume and return the request body as JSON , header -- | Add a header to the response , status -- | Set the response status , file -- | Send a file as response + , filepart -- | Send a part of a file as response , stream -- | Stream a response , raw -- | Set the raw response body , json -- | Set the json response body @@ -31,18 +43,19 @@ , javascript -- | Set the javascript response body , asContent -- | Set the contentType and a 'Text' body , next -- | Run the next application in the stack - , rawBody -- | Consume and return the request body as a lazy bytestring - , jsonBody -- | Consume and return the request body as JSON + , setCookie -- | Add a cookie to the response + , getCookie -- | Get a cookie from the request + , getCookies -- | Get all cookies from the request ) where -import Network.Wai (Request, Response, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody) +import Network.Wai (Request, Response, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody, requestHeaders, FilePart) #if MIN_VERSION_wai(3,0,1) import Network.Wai (strictRequestBody) #endif -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, typeCss, typeJavascript) +import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler, showRoute, showRouteQuery, readRoute) +import Network.Wai.Middleware.Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..)) +import Network.Wai.Middleware.Routes.ContentTypes (contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript) import Control.Monad (liftM) import Control.Monad.Loops (unfoldWhileM) @@ -54,7 +67,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Network.HTTP.Types.Header (HeaderName()) +import Blaze.ByteString.Builder (Builder, toByteString, fromLazyByteString) +import Network.HTTP.Types.Header (HeaderName(), RequestHeaders) import Network.HTTP.Types.Status (Status(), status200) import Data.Aeson (ToJSON, FromJSON, eitherDecode) @@ -64,12 +78,16 @@ import qualified Data.Set as S (empty, map) import Data.Text.Lazy (Text) +import qualified Data.Text as TS (Text) import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8) -import Blaze.ByteString.Builder (fromLazyByteString) +import Data.CaseInsensitive (CI, mk) +import Web.Cookie (Cookies, parseCookies, renderCookies, renderSetCookie, SetCookie(..)) +import Data.Default.Class (def) + -- | The internal implementation of the HandlerM monad -- TODO: Should change this to StateT over ReaderT (but performance may suffer) newtype HandlerMI sub master m a = H { extractH :: StateT (HandlerState sub master) m a } @@ -87,19 +105,44 @@ , reqBody :: Maybe BL.ByteString , respHeaders :: [(HeaderName, ByteString)] , respStatus :: Status - , respResp :: Maybe ResponseHandler + , respResp :: MkResponse + , respCookies :: [SetCookie] , getSub :: sub , toMasterRoute :: Route sub -> Route master } +-- Internal: Type of response +-- Similar to Wai's Response type +data MkResponse + = ResponseFile FilePath (Maybe FilePart) + | ResponseBuilder Builder + | ResponseStream StreamingBody + -- Experimental: ResponseNext is the default, so if you don't respond in one handler, move to next automatically + | ResponseNext + +-- The header name for request cookies +cookieHeaderName :: CI ByteString +cookieHeaderName = mk "Cookie" + +-- The header name for response cookies +cookieSetHeaderName :: CI ByteString +cookieSetHeaderName = mk "Set-Cookie" + -- | "Run" HandlerM, resulting in a Handler runHandlerM :: HandlerM sub master () -> HandlerS sub master runHandlerM h env req hh = do - (_, st) <- runStateT (extractH h) (HandlerState (envMaster env) req Nothing [] status200 Nothing (envSub env) (envToMaster env)) - case respResp st of - -- Experimental, if you don't respond in one handler, move to next automatically - Nothing -> runNext (getRequestData st) hh - Just resp -> resp hh + (_, st) <- runStateT (extractH h) (HandlerState (envMaster env) req Nothing [] status200 ResponseNext [] (envSub env) (envToMaster env)) + -- Handle cookies (add them to headers) + let cookieHeaders = map mkSetCookie (respCookies st) + let st' = st {respHeaders = cookieHeaders ++ (respHeaders st)} + -- Construct response + mkResponse st' (respResp st') + where + mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s) + mkResponse st (ResponseFile path part) = hh $ responseFile (respStatus st) (respHeaders st) path part + mkResponse st (ResponseBuilder builder) = hh $ responseBuilder (respStatus st) (respHeaders st) builder + mkResponse st (ResponseStream streaming) = hh $ responseStream (respStatus st) (respHeaders st) streaming + mkResponse st ResponseNext = runNext (getRequestData st) hh -- | Get the request body as a lazy bytestring. However consumes the entire body at once. -- TODO: Implement streaming. Prevent clash with direct use of `Network.Wai.requestBody` @@ -109,18 +152,19 @@ case reqBody s of Just consumedBody -> return consumedBody Nothing -> do -#if MIN_VERSION_wai(3,0,1) - -- Use the `strictRequestBody` function available in wai > 3.0.1 req <- request - rbody <- liftIO $ strictRequestBody req + rbody <- liftIO $ readStrictRequestBody req put s {reqBody = Just rbody} return rbody + +readStrictRequestBody :: Request -> IO BL.ByteString +readStrictRequestBody = +#if MIN_VERSION_wai(3,0,1) + -- Use the `strictRequestBody` function available in wai > 3.0.1 + strictRequestBody #else - -- Consume the entire body, and cache - chunker <- fmap requestBody request - consumedBody <- liftIO $ BL.fromChunks <$> unfoldWhileM (not . B.null) chunker - put s {reqBody = Just consumedBody} - return consumedBody + -- Consume the entire body, and cache + BL.fromChunks <$> unfoldWhileM (not . B.null) . requestBody #endif -- | Parse the body as a JSON object @@ -139,6 +183,14 @@ request :: HandlerM sub master Request request = liftM (waiReq . getRequestData) get +-- | Get a particular request header (Case insensitive) +reqHeader :: ByteString -> HandlerM sub master (Maybe ByteString) +reqHeader name = liftM (lookup $ mk name) reqHeaders + +-- | Get all request headers (Case insensitive) +reqHeaders :: HandlerM sub master RequestHeaders +reqHeaders = liftM requestHeaders request + -- | Get the current route maybeRoute :: HandlerM sub master (Maybe (Route sub)) maybeRoute = liftM (currentRoute . getRequestData) get @@ -149,6 +201,36 @@ s <- get return $ fmap (toMasterRoute s) $ currentRoute $ getRequestData s +-- | Get the route rendering function for the master site +showRouteMaster :: RenderRoute master => HandlerM sub master (Route master -> TS.Text) +showRouteMaster = return showRoute + +-- | Get the route rendering function for the subsite +showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> TS.Text) +showRouteSub = do + s <- get + return $ showRoute . toMasterRoute s + +-- | Get the route rendering function for the master site +showRouteQueryMaster :: RenderRoute master => HandlerM sub master (Route master -> [(TS.Text,TS.Text)] -> TS.Text) +showRouteQueryMaster = return showRouteQuery + +-- | Get the route rendering function for the subsite +showRouteQuerySub :: RenderRoute master => HandlerM sub master (Route sub -> [(TS.Text,TS.Text)] -> TS.Text) +showRouteQuerySub = do + s <- get + return $ showRouteQuery . toMasterRoute s + +-- | Get the route parsing function for the master site +readRouteMaster :: ParseRoute master => HandlerM sub master (TS.Text -> Maybe (Route master)) +readRouteMaster = return readRoute + +-- | Get the route parsing function for the subsite +readRouteSub :: ParseRoute sub => HandlerM sub master (TS.Text -> Maybe (Route master)) +readRouteSub = do + s <- get + return $ fmap (toMasterRoute s) . readRoute + -- | Get the current route attributes routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text) routeAttrSet = liftM (S.map T.fromStrict . maybe S.empty routeAttrs . currentRoute . getRequestData) get @@ -174,43 +256,47 @@ setStatus :: Status -> HandlerState sub master -> HandlerState sub master setStatus s st = st{respStatus=s} --- | Set the response body to a file +-- | Send a file as response file :: FilePath -> HandlerM sub master () -file f = modify addFile +file f = do + header contentType $ contentTypeFromFile f + modify addFile where - addFile st = setResp st $ responseFile (respStatus st) (respHeaders st) f Nothing + addFile st = _setResp st $ ResponseFile f Nothing +-- | Send a part of a file as response +filepart :: FilePath -> FilePart -> HandlerM sub master () +filepart f part = do + header contentType $ contentTypeFromFile f + modify addFile + where + addFile st = _setResp st $ ResponseFile f (Just part) + -- | Stream the response stream :: StreamingBody -> HandlerM sub master () stream s = modify addStream where - addStream st = setResp st $ responseStream (respStatus st) (respHeaders st) s + addStream st = _setResp st $ ResponseStream s -- | Set the response body raw :: BL.ByteString -> HandlerM sub master () raw bs = modify addBody where - addBody st = setResp st $ responseBuilder (respStatus st) (respHeaders st) (fromLazyByteString bs) + addBody st = _setResp st $ ResponseBuilder (fromLazyByteString bs) -- | Run the next application next :: HandlerM sub master () -next = do - respHandler <- fmap (runNext . getRequestData) get - modify $ setRespHandler respHandler - --- Util --- Set the response directly --- This is a bit convulated to enable clean usage in calling functions -setResp :: HandlerState sub master -> Response -> HandlerState sub master -setResp st r = setRespHandler ($ r) st +next = modify rNext + where + rNext st = _setResp st ResponseNext -- Util -- Set the response handler --- Don't overwrite previous response handler -setRespHandler :: ResponseHandler -> HandlerState sub master -> HandlerState sub master -setRespHandler r st = case respResp st of - Just _ -> st - Nothing -> st{respResp=Just r} +-- Experimental: Don't overwrite previous response handler +_setResp :: HandlerState sub master -> MkResponse -> HandlerState sub master +_setResp st r = case respResp st of + ResponseNext -> st{respResp=r} + _ -> st -- Standard response bodies @@ -249,3 +335,24 @@ header contentType ctype raw $ encodeUtf8 content +-- | Sets a cookie to the response +setCookie :: SetCookie -> HandlerM sub master () +setCookie s = modify setCookie + where + setCookie st = st {respCookies = s : respCookies st} + +-- | Get all cookies +getCookies :: HandlerM sub master Cookies +getCookies = do + -- Note: We don't cache the parsedCookies for all requests to avoid overhead + -- However it is pretty easy to cache cookies in the app itself + cookies <- reqHeader "Cookie" + return $ case cookies of + Nothing -> [] + Just cookies' -> parseCookies cookies' + +-- | Get a particular cookie +getCookie :: ByteString -> HandlerM sub master (Maybe ByteString) +getCookie name = do + cookies <- getCookies + return $ lookup name cookies diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} 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.7.3 +version : 0.8.0 cabal-version : >=1.18 build-type : Simple license : MIT @@ -20,23 +20,28 @@ source-repository this type : git - location : http://github.com/ajnsit/wai-routes/tree/v0.7.3 - tag : v0.7.3 + location : http://github.com/ajnsit/wai-routes/tree/v0.8.0 + tag : v0.8.0 library - build-depends: base >= 4.7 && < 4.9 - , wai >= 3.0 && < 3.1 - , text >= 1.2 && < 1.3 - , template-haskell >= 2.9 && < 2.11 - , mtl >= 2.1 && < 2.3 - , aeson >= 0.8 && < 0.10 - , containers >= 0.5 && < 0.6 - , random >= 1.1 && < 1.2 - , path-pieces >= 0.2 && < 0.3 - , bytestring >= 0.10 && < 0.11 - , http-types >= 0.8 && < 0.9 - , blaze-builder >= 0.4 && < 0.5 - , monad-loops >= 0.4 && < 0.5 + build-depends: base >= 4.7 && < 4.9 + , wai >= 3.0 && < 3.1 + , text >= 1.2 && < 1.3 + , template-haskell >= 2.9 && < 2.11 + , mtl >= 2.1 && < 2.3 + , aeson >= 0.8 && < 0.10 + , containers >= 0.5 && < 0.6 + , random >= 1.1 && < 1.2 + , path-pieces >= 0.2 && < 0.3 + , bytestring >= 0.10 && < 0.11 + , http-types >= 0.8 && < 0.9 + , blaze-builder >= 0.4 && < 0.5 + , monad-loops >= 0.4 && < 0.5 + , case-insensitive >= 1.2 && < 1.3 + , mime-types >= 0.1 && < 0.2 + , filepath >= 1.3 && < 1.5 + , cookie >= 0.4 && < 0.5 + , data-default-class >= 0.0 && < 0.1 exposed-modules: Network.Wai.Middleware.Routes Network.Wai.Middleware.Routes.Parse Network.Wai.Middleware.Routes.Overlap @@ -56,3 +61,18 @@ buildable : True hs-source-dirs : src default-language : Haskell2010 + +test-suite test + main-is: Spec.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + GHC-options: -Wall -threaded -fno-warn-orphans + + build-depends: base >= 4.7 && < 4.9 + , wai >= 3.0 && < 3.1 + , aeson >= 0.8 && < 0.9 + , hspec >= 2.1 && < 2.2 + , hspec-wai >= 0.6 && < 0.7 + , hspec-wai-json >= 0.6 && < 0.7 + , wai-routes