diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.8.1-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.9.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) ==================================== Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. @@ -16,6 +16,7 @@ - Nested Routes - Subsites - Route Annotations + - Seamlessly mix and match "unrouted" request handlers with typesafe routing. - 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 @@ -62,7 +63,32 @@ Wai has had the ability to stream content for a long time. Now wai-routes exposes this functionality with the `stream` function. This example shows how to stream content in a handler. Note that most browsers using default settings will not show content as it is being streamed. You can use "curl" to observe the effect of streaming. E.g. - `curl localhost:8080` will dump the data as it is being streamed from the server. +**Example 7. Kitchen sink ** - [Code](examples/kitchen) +*Work in progress*. Demonstrates all major features in wai-routes. + + +Deployment +========== + +The current recommended route (pun not intended) for deploying wai-routes apps is [keter](http://hackage.haskell.org/package/keter). You need to read the port from the environment variables - + + -- Run the application + main :: IO () + main = do + port' <- getEnv "PORT" + let port = read port' + run port $ waiApp application + +Then put something like this in `config/keter.yaml` - + + exec: ../path/to/executable + host: mydomainname.example.com + +Then create a tarball with `config/keter.yaml`, `path/to/executable`, and any other files needed at runtime for your application. Rename the tarball to have a `.keter` extension. + +Upload that file to your server's `incoming` folder for keter to pick it up. You obviously need keter already installed and configured properly at the server. + Planned Features ==================== @@ -71,15 +97,15 @@ - 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 -- Better documentation -- Tests and code coverage +- Better documentation, and a getting started tutorial +- More tests and code coverage Changelog ========= +* 0.9.0 : Support for "unrouted" handlers. API changes to avoid returning lazy text or bytestring. Methods to fetch post/file params. Removed 'HandlerMM' and made 'Handler' more useful. * 0.8.1 : Bumped dependencies. Added 'HandlerMM' type alias * 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. 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 @@ -51,6 +51,9 @@ -- * Route Monad makes it easy to compose routes together , RouteM + , DefaultMaster(..) + , Route(DefaultRoute) + , handler -- | Add a wai-routes handler , catchall -- | Catch all routes with the supplied application , defaultAction -- | A synonym for `catchall`, kept for backwards compatibility , middleware -- | Add another middleware to the app @@ -60,9 +63,9 @@ -- * HandlerM Monad makes it easy to build a handler , HandlerM() - , HandlerMM() -- | HandlerM Monad specialised for top level sites (no subsites) , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data + , isWebsocket -- | Is this a websocket request , reqHeader -- | Get a particular request header (case insensitive) , reqHeaders -- | Get all request headers (case insensitive) , maybeRootRoute -- | Access the current route for root route @@ -79,6 +82,7 @@ , filepart -- | Send a part of a file as response , stream -- | Stream a response , raw -- | Set the raw response body + , rawBuilder -- | Set the raw response body as a ByteString Builder , json -- | Set the json response body , plain -- | Set the plain text response body , html -- | Set the html response body @@ -86,13 +90,29 @@ , javascript -- | Set the javascript response body , asContent -- | Set the contentType and a 'Text' body , next -- | Run the next application in the stack + , getParams -- | Get all params (query or post, not file) + , getParam -- | Get a particular param (query or post, not file) + , getQueryParams -- | Get all query params + , getQueryParam -- | Get a particular query param + , getPostParams -- | Get all post params + , getPostParam -- | Get a particular post param + , getFileParams -- | Get all file params + , getFileParam -- | Get a particular file param , setCookie -- | Add a cookie to the response , getCookie -- | Get a cookie from the request , getCookies -- | Get all cookies from the request + + , module Network.HTTP.Types.Status + , module Network.Wai.Middleware.RequestLogger + , module Network.Wai.Application.Static + , Text ) where import Network.Wai.Middleware.Routes.Routes import Network.Wai.Middleware.Routes.Monad import Network.Wai.Middleware.Routes.Handler - +import Network.HTTP.Types.Status +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Application.Static +import Data.Text (Text) diff --git a/src/Network/Wai/Middleware/Routes/DefaultRoute.hs b/src/Network/Wai/Middleware/Routes/DefaultRoute.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Routes/DefaultRoute.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Network.Wai.Middleware.Routes.DefaultRoute +Copyright : (c) Anupam Jain 2013 - 2015 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +Defines a DefaultMaster datatype and associated route (DefaultRoute) which is used for "unrouted" handlers +-} +module Network.Wai.Middleware.Routes.DefaultRoute + ( DefaultMaster(..) + , Route(DefaultRoute) + ) + where + +import Data.Text (Text) +import Data.Set (empty) + +import Network.Wai.Middleware.Routes.Routes + +-- Default master datatype, which is used for "unrouted" handlers +data DefaultMaster = DefaultMaster +-- This makes it possible to define handlers without routing stuff +instance RenderRoute DefaultMaster where + -- The associated route simply contains all path information + data Route DefaultMaster = DefaultRoute ([Text],[(Text, Text)]) deriving Eq + renderRoute (DefaultRoute r) = r +instance ParseRoute DefaultMaster where + parseRoute = Just . DefaultRoute +instance RouteAttrs DefaultMaster where + routeAttrs = const empty 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 @@ -12,9 +12,9 @@ -} module Network.Wai.Middleware.Routes.Handler ( HandlerM() -- | A Monad that makes it easier to build a Handler - , HandlerMM() -- | HandlerM Monad specialised for top level sites (no subsites) , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data + , isWebsocket -- | Is this a websocket request , reqHeader -- | Get a particular request header (case insensitive) , reqHeaders -- | Get all request headers (case insensitive) , routeAttrSet -- | Access the route attribute list @@ -29,7 +29,7 @@ , 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 + , rawBody -- | Consume and return the request body as a bytestring , jsonBody -- | Consume and return the request body as JSON , header -- | Add a header to the response , status -- | Set the response status @@ -37,6 +37,7 @@ , filepart -- | Send a part of a file as response , stream -- | Stream a response , raw -- | Set the raw response body + , rawBuilder -- | Set the raw response body as a ByteString Builder , json -- | Set the json response body , plain -- | Set the plain text response body , html -- | Set the html response body @@ -44,17 +45,25 @@ , javascript -- | Set the javascript response body , asContent -- | Set the contentType and a 'Text' body , next -- | Run the next application in the stack + , getParams -- | Get all params (query or post, not file) + , getParam -- | Get a particular param (query or post, not file) + , getQueryParams -- | Get all query params + , getQueryParam -- | Get a particular query param + , getPostParams -- | Get all post params + , getPostParam -- | Get a particular post param + , getFileParams -- | Get all file params + , getFileParam -- | Get a particular file param , 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, requestHeaders, FilePart) +import Network.Wai (Request, Response, responseRaw, 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, showRoute, showRouteQuery, readRoute) +import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler, showRoute, showRouteQuery, readRoute, readQueryString) import Network.Wai.Middleware.Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..)) import Network.Wai.Middleware.Routes.ContentTypes (contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript) @@ -62,33 +71,34 @@ import Control.Monad.Loops (unfoldWhileM) import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, liftIO, MonadTrans) -import Control.Applicative (Applicative, (<$>)) +import Control.Applicative (Applicative, (<$>), (<*>)) import Data.Maybe (maybe) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Blaze.ByteString.Builder (Builder, toByteString, fromLazyByteString) +import Blaze.ByteString.Builder (Builder, toByteString, fromByteString) import Network.HTTP.Types.Header (HeaderName(), RequestHeaders) import Network.HTTP.Types.Status (Status(), status200) -import Data.Aeson (ToJSON, FromJSON, eitherDecode) +import Data.Aeson (ToJSON, FromJSON, eitherDecodeStrict) + import qualified Data.Aeson as A +import qualified Data.Aeson.Encode as AE import Data.Set (Set) 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 Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.CaseInsensitive (CI, mk) -import Web.Cookie (Cookies, parseCookies, renderCookies, renderSetCookie, SetCookie(..)) +import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..)) import Data.Default.Class (def) +import qualified Network.Wai.Parse as P + -- | 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 } @@ -97,33 +107,81 @@ -- | The HandlerM Monad type HandlerM sub master a = HandlerMI sub master IO a --- | A HandlerMM is a HandlerM Monad for use with a top level site (where the sub and master datatypes are the same) -type HandlerMM master a = HandlerM master master a +-- | Modeled after Network.Wai.Parse.FileInfo, but uses Text for names, and lazy ByteString for content +data FileInfo = FileInfo + { fileName :: Text + , fileContentType :: Text + , fileContent :: BL.ByteString + } +-- Post Params +-- Files are read into memory +-- TODO: Check for security issues. Allow automatic storing of files on disk. +type PostParams = ([(Text, Text)], [(Text, FileInfo)]) + +-- Private +-- Convert from Network.Wai.Parse ([Param], [File y]) to PostParams +_toPostParams :: ([P.Param], [P.File BL.ByteString]) -> PostParams +_toPostParams (params, files) = (params', files') + where + params' = map (\(k,v) -> (decodeUtf8 k, decodeUtf8 v)) params + files' = map (\(k,v) -> (decodeUtf8 k, decodeFileInfo v)) files + decodeFileInfo fi = FileInfo + { fileName = decodeUtf8 $ P.fileName fi + , fileContentType = decodeUtf8 $ P.fileContentType fi + , fileContent = P.fileContent fi + } + +-- A Raw Response handler :: source -> sink -> IO +type RespRawHandler = IO B.ByteString -> (B.ByteString -> IO ()) -> IO () + -- | The state kept in a HandlerM Monad data HandlerState sub master = HandlerState - { getMaster :: master - , getRequestData :: RequestData sub - -- TODO: Experimental - -- Streaming request body, consumed, and stored as a ByteString - , reqBody :: Maybe BL.ByteString - , respHeaders :: [(HeaderName, ByteString)] - , respStatus :: Status - , respResp :: MkResponse - , respCookies :: [SetCookie] - , getSub :: sub - , toMasterRoute :: Route sub -> Route master - } + { getMaster :: master + , getRequestData :: RequestData sub + -- TODO: Experimental + -- Streaming request body, consumed, and stored as a ByteString + , reqBody :: Maybe ByteString + , respHeaders :: [(HeaderName, ByteString)] + , respStatus :: Status + , respResp :: MkResponse + , respRaw :: Maybe RespRawHandler + , respCookies :: [SetCookie] + , getSub :: sub + , toMasterRoute :: Route sub -> Route master + -- TODO: Experimental + -- Parsed POST request body, in the same format as Network.Wai.Parse + , postParams :: Maybe PostParams + } +-- Initial Handler State +defaultHandlerState :: Env sub master -> RequestData sub -> HandlerState sub master +defaultHandlerState env req = HandlerState + { getMaster = envMaster env + , getRequestData = req + , reqBody = Nothing + , respHeaders = [] + , respStatus = status200 + , respResp = defaultResponse + , respRaw = Nothing + , respCookies = [] + , getSub = envSub env + , toMasterRoute = envToMaster env + , postParams = Nothing + } + -- 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 +-- Default response in case none is set by the handler +defaultResponse :: MkResponse +defaultResponse = ResponseBuilder "" + -- The header name for request cookies cookieHeaderName :: CI ByteString cookieHeaderName = mk "Cookie" @@ -135,34 +193,45 @@ -- | "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 ResponseNext [] (envSub env) (envToMaster env)) + (_, st) <- runStateT (extractH h) (defaultHandlerState env req) -- 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') + st <- return $ st {respHeaders = cookieHeaders ++ (respHeaders st)} + case respResp st of + -- Abort handling current response and move to next handler + ResponseNext -> runNext (getRequestData st) hh + -- Normal handling + normalResponse -> do + -- Construct the normal response + let resp = mkResponse st normalResponse + -- Check if we are trying to send a raw response + case respRaw st of + Nothing -> hh resp + Just rawHandler -> + -- TODO: Ensure the body has not been read before using raw response + hh $ responseRaw rawHandler resp 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 + mkResponse st (ResponseFile path part) = responseFile (respStatus st) (respHeaders st) path part + mkResponse st (ResponseBuilder builder) = responseBuilder (respStatus st) (respHeaders st) builder + mkResponse st (ResponseStream streaming) = responseStream (respStatus st) (respHeaders st) streaming --- | Get the request body as a lazy bytestring. However consumes the entire body at once. +-- | Get the request body as a bytestring. Consumes the entire body into memory at once. -- TODO: Implement streaming. Prevent clash with direct use of `Network.Wai.requestBody` -rawBody :: HandlerM master master BL.ByteString +rawBody :: HandlerM sub master ByteString rawBody = do s <- get case reqBody s of Just consumedBody -> return consumedBody Nothing -> do req <- request - rbody <- liftIO $ readStrictRequestBody req + rbody <- liftIO $ BL.toStrict <$> _readStrictRequestBody req put s {reqBody = Just rbody} return rbody -readStrictRequestBody :: Request -> IO BL.ByteString -readStrictRequestBody = +-- PRIVATE +_readStrictRequestBody :: Request -> IO BL.ByteString +_readStrictRequestBody = #if MIN_VERSION_wai(3,0,1) -- Use the `strictRequestBody` function available in wai > 3.0.1 strictRequestBody @@ -172,8 +241,8 @@ #endif -- | Parse the body as a JSON object -jsonBody :: FromJSON a => HandlerM master master (Either String a) -jsonBody = liftM eitherDecode rawBody +jsonBody :: FromJSON a => HandlerM sub master (Either String a) +jsonBody = liftM eitherDecodeStrict rawBody -- | Get the master master :: HandlerM sub master master @@ -187,11 +256,21 @@ request :: HandlerM sub master Request request = liftM (waiReq . getRequestData) get +-- | Is this a websocket request +isWebsocket :: HandlerM sub master Bool +isWebsocket = liftM (maybe False (== "websocket")) (reqHeader "upgrade") + -- | Get a particular request header (Case insensitive) -reqHeader :: ByteString -> HandlerM sub master (Maybe ByteString) -reqHeader name = liftM (lookup $ mk name) reqHeaders +reqHeader :: Text -> HandlerM sub master (Maybe Text) +reqHeader name = liftM (fmap decodeUtf8) (_reqHeaderBS nameText) + where + nameText = mk $ encodeUtf8 name --- | Get all request headers (Case insensitive) +-- PRIVATE +_reqHeaderBS :: CI ByteString -> HandlerM sub master (Maybe ByteString) +_reqHeaderBS name = liftM (lookup name) reqHeaders + +-- | Get all request headers as raw case-insensitive bytestrings reqHeaders :: HandlerM sub master RequestHeaders reqHeaders = liftM requestHeaders request @@ -203,47 +282,47 @@ maybeRootRoute :: HandlerM sub master (Maybe (Route master)) maybeRootRoute = do s <- get - return $ fmap (toMasterRoute s) $ currentRoute $ getRequestData s + return $ 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 :: RenderRoute master => HandlerM sub master (Route master -> Text) showRouteMaster = return showRoute -- | Get the route rendering function for the subsite -showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> TS.Text) +showRouteSub :: RenderRoute master => HandlerM sub master (Route sub -> 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 :: RenderRoute master => HandlerM sub master (Route master -> [(Text,Text)] -> 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 :: RenderRoute master => HandlerM sub master (Route sub -> [(Text,Text)] -> 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 :: ParseRoute master => HandlerM sub master (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 :: ParseRoute sub => HandlerM sub master (Text -> Maybe (Route master)) readRouteSub = do s <- get - return $ fmap (toMasterRoute s) . readRoute + return $ (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 +routeAttrSet = liftM (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 + return $ maybe S.empty (routeAttrs . toMasterRoute s) $ currentRoute $ getRequestData s -- | Add a header to the application response -- TODO: Differentiate between setting and adding headers @@ -283,10 +362,14 @@ addStream st = _setResp st $ ResponseStream s -- | Set the response body -raw :: BL.ByteString -> HandlerM sub master () -raw bs = modify addBody +raw :: ByteString -> HandlerM sub master () +raw = rawBuilder . fromByteString + +-- | Set the response body as a builder +rawBuilder :: Builder -> HandlerM sub master () +rawBuilder b = modify addBody where - addBody st = _setResp st $ ResponseBuilder (fromLazyByteString bs) + addBody st = _setResp st $ ResponseBuilder b -- | Run the next application next :: HandlerM sub master () @@ -296,12 +379,10 @@ -- Util -- Set the response handler --- 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 +_setResp st r = st{respResp=r} + -- Standard response bodies -- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\" @@ -309,7 +390,13 @@ json :: ToJSON a => a -> HandlerM sub master () json a = do header contentType typeJson - raw $ A.encode a + rawBuilder $ _encode $ A.toJSON a + where +#if MIN_VERSION_aeson(0,9,0) + _encode = AE.encodeToBuilder +#else + _encode = AE.encodeToByteStringBuilder +#endif -- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" -- header to \"text/plain\". @@ -346,17 +433,90 @@ setCookie st = st {respCookies = s : respCookies st} -- | Get all cookies -getCookies :: HandlerM sub master Cookies +getCookies :: HandlerM sub master CookiesText 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" + cookies <- _reqHeaderBS cookieHeaderName return $ case cookies of Nothing -> [] - Just cookies' -> parseCookies cookies' + Just cookies' -> parseCookiesText cookies' -- | Get a particular cookie -getCookie :: ByteString -> HandlerM sub master (Maybe ByteString) +getCookie :: Text -> HandlerM sub master (Maybe Text) getCookie name = do cookies <- getCookies return $ lookup name cookies + +-- PRIVATE +-- Get the cached post params (if any) +_getCachedPostParams :: HandlerM sub master (Maybe PostParams) +_getCachedPostParams = postParams <$> get + +-- PRIVATE +-- Util: Parse and cache post params +_populatePostParams :: HandlerM sub master PostParams +_populatePostParams = do + st <- get + case postParams st of + Just params -> return params + Nothing -> do + req <- request + params <- case P.getRequestBodyType req of + Nothing -> return ([],[]) + Just _ -> do + -- TODO: Use cached request body instead of reading it from wai request + params <- liftIO $ P.parseRequestBody P.lbsBackEnd req + return $ _toPostParams params + put $ st{postParams=Just params} + return params + +-- PRIVATE +-- Get a list of post parameters +_getAllFileOrPostParams :: HandlerM sub master PostParams +_getAllFileOrPostParams = do + cachedPostParams <- _getCachedPostParams + case cachedPostParams of + Nothing -> _populatePostParams + Just params -> return params + +-- | Get all Query params +getQueryParams :: HandlerM sub master [(Text,Text)] +getQueryParams = readQueryString . queryString <$> request + +-- | Get a particular Query param +getQueryParam :: Text -> HandlerM sub master (Maybe Text) +getQueryParam name = lookup name <$> getQueryParams + +-- | Get all Post params +getPostParams :: HandlerM sub master [(Text,Text)] +getPostParams = do + (params,_) <- _getAllFileOrPostParams + return params + +-- | Get a particular Post param +getPostParam :: Text -> HandlerM sub master (Maybe Text) +getPostParam name = lookup name <$> getPostParams + +-- | Get all File params +getFileParams :: HandlerM sub master [(Text,FileInfo)] +getFileParams = do + (_,files) <- _getAllFileOrPostParams + return files + +-- | Get a particular File param +getFileParam :: Text -> HandlerM sub master (Maybe FileInfo) +getFileParam name = lookup name <$> getFileParams + +-- | Get all params (query or post, NOT file) +-- Duplicate parameters are preserved +getParams :: HandlerM sub master [(Text, Text)] +getParams = (++) <$> getQueryParams <*> getPostParams + +-- | Get a param (query or post, NOT file) +getParam :: Text -> HandlerM sub master (Maybe Text) +getParam name = do + getLookup <- getQueryParam name + case getLookup of + Nothing -> getPostParam name + Just _ -> return $ getLookup 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TypeFamilies, RankNTypes, DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-} {- | Module : Network.Wai.Middleware.Routes.Monad @@ -15,6 +15,9 @@ ( -- * Route Monad RouteM -- * Compose Routes + , DefaultMaster(..) + , Route(DefaultRoute) + , handler , middleware , route , catchall @@ -27,7 +30,8 @@ import Network.Wai import Network.Wai.Middleware.Routes.Routes -import Network.HTTP.Types +import Network.Wai.Middleware.Routes.DefaultRoute +import Network.HTTP.Types (status404) import Util.Free (F(..), liftF) @@ -47,10 +51,17 @@ defaultAction = catchall -- | Add a middleware to the application --- Middleware are ordered so the one declared earlier is wraps the remaining application. +-- Middleware are ordered so the one declared earlier wraps the ones later middleware :: Middleware -> RouteM () middleware m = liftF $ M m () +-- | Add a wai-routes handler +handler :: Handler DefaultMaster -> RouteM () +handler h = middleware $ customRouteDispatch dispatcher' DefaultMaster + where + dispatcher' env req = runHandler h env (Just $ DefaultRoute $ getRoute req) req + getRoute req = (pathInfo $ waiReq req, readQueryString $ queryString $ waiReq req) + -- | Add a route to the application. -- Routes are ordered so the one declared earlier is matched first. route :: (Routable master master) => master -> RouteM () @@ -66,7 +77,7 @@ waiApp :: RouteM () -> Application waiApp (F r) = r (const defaultApplication) f where - f (M m r) = m r + f (M m r') = m r' f (D a) = a -- | Similar to waiApp but returns the app in an arbitrary monad 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 @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {- | Module : Network.Wai.Middleware.Routes.Routes Copyright : (c) Anupam Jain 2013 @@ -29,6 +30,7 @@ -- * Dispatch , routeDispatch + , customRouteDispatch -- * URL rendering and parsing , showRoute @@ -57,12 +59,15 @@ , currentRoute -- | Extract the current `Route` from `RequestData` , runNext -- | Run the next application in the stack + -- * Not exported outside wai-routes + , runHandler + , readQueryString ) where -- Wai import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..)) -import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText) +import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText) -- Network.Wai.Middleware.Routes import Network.Wai.Middleware.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..)) @@ -107,14 +112,14 @@ runNext req = nextApp req $ waiReq req -- | A `Handler` generates an App from the master datatype -type Handler master = HandlerS master master +type Handler sub = forall master. RenderRoute master => HandlerS sub master type HandlerS sub master = Env sub master -> App sub -- | 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 rname = mkName $ "_resources" ++ typName let resourceTrees = map (fmap parseType) routes eres <- lift routes let resourcesDec = @@ -159,7 +164,7 @@ let typ = parseType typName disp <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [| runHandler |] - , mdsSubDispatcher = [| subDispatcher |] + , mdsSubDispatcher = [| subDispatcher |] , mdsGetPathInfo = [| getPathInfo |] , mdsMethod = [| getReqMethod |] , mdsSetPathInfo = [| setPathInfo |] @@ -189,9 +194,15 @@ -- | Generates the application middleware from a `Routable` master datatype routeDispatch :: Routable master master => master -> Middleware +routeDispatch = customRouteDispatch dispatcher + +-- | Like routeDispatch but generates the application middleware from a custom dispatcher +customRouteDispatch :: HandlerS master master -> master -> Middleware +-- TODO: Should this have master master instead of sub master? +-- TODO: Verify that this plays well with subsites -- Env master master is converted to Env sub master by subDispatcher -- Route information is filled in by runHandler -routeDispatch master def req = dispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing} +customRouteDispatch customDispatcher master def req = customDispatcher (_masterToEnv master) RequestData{waiReq=req, nextApp=def, currentRoute=Nothing} -- | Render a `Route` and Query parameters to Text showRouteQuery :: RenderRoute master => Route master -> [(Text,Text)] -> Text @@ -209,8 +220,12 @@ -- | 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 +readRoute = parseRoute . second readQueryString . decodePath . encodeUtf8 +-- | Convert a Query to the format expected by parseRoute +readQueryString :: Query -> [(Text, Text)] +readQueryString = map (second (fromMaybe "")) . queryToQueryText + -- PRIVATE -- Get the request method from a RequestData @@ -236,6 +251,8 @@ app405 _master = runNext -- Run a route handler function +-- Currently all this does is populate the route into RequestData +-- But it may do more in the future runHandler :: HandlerS sub master -> Env sub master @@ -255,8 +272,8 @@ where env' = _envToSub getSub toMasterRoute env reqData' = reqData{currentRoute=Nothing} - qq (k,mv) = (decodeUtf8 k, maybe "" decodeUtf8 mv) - req = waiReq reqData + -- qq (k,mv) = (decodeUtf8 k, maybe "" decodeUtf8 mv) + -- req = waiReq reqData _masterToEnv :: master -> Env master master _masterToEnv master = Env master master id diff --git a/wai-routes.cabal b/wai-routes.cabal --- a/wai-routes.cabal +++ b/wai-routes.cabal @@ -1,14 +1,14 @@ -name : wai-routes -version : 0.8.1 -cabal-version : >=1.18 -build-type : Simple -license : MIT -license-file : LICENSE -maintainer : ajnsit@gmail.com -stability : Experimental -homepage : https://ajnsit.github.io/wai-routes/ -synopsis : Typesafe URLs for Wai applications. -description : Provides easy to use typesafe URLs for Wai Applications. See README for more information. Also see examples/ directory for usage examples. +name : wai-routes +version : 0.9.0 +cabal-version : >=1.18 +build-type : Simple +license : MIT +license-file : LICENSE +maintainer : ajnsit@gmail.com +stability : Experimental +homepage : https://ajnsit.github.io/wai-routes/ +synopsis : Typesafe URLs for Wai applications. +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 : "" @@ -20,59 +20,63 @@ source-repository this type : git - location : http://github.com/ajnsit/wai-routes/tree/v0.8.1 - tag : v0.8.1 + location : http://github.com/ajnsit/wai-routes/tree/v0.9.0 + tag : v0.9.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 - , 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 - Network.Wai.Middleware.Routes.Class - Network.Wai.Middleware.Routes.Routes - Network.Wai.Middleware.Routes.Monad - Network.Wai.Middleware.Routes.Handler - Network.Wai.Middleware.Routes.ContentTypes - Network.Wai.Middleware.Routes.TH - Network.Wai.Middleware.Routes.TH.Types - Network.Wai.Middleware.Routes.TH.Dispatch - Network.Wai.Middleware.Routes.TH.ParseRoute - Network.Wai.Middleware.Routes.TH.RenderRoute - Network.Wai.Middleware.Routes.TH.RouteAttrs - Util.Free - exposed : True - buildable : True - hs-source-dirs : src + build-depends : base >= 4.7 && < 4.9 + , wai >= 3.0 && < 3.1 + , wai-extra >= 3.0 && < 3.1 + , wai-app-static >= 3.0 && < 3.2 + , text >= 1.2 && < 1.3 + , template-haskell >= 2.9 && < 2.11 + , mtl >= 2.1 && < 2.3 + , aeson >= 0.8 && < 0.11 + , 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 + other-modules : Network.Wai.Middleware.Routes.Parse + Network.Wai.Middleware.Routes.Overlap + Network.Wai.Middleware.Routes.Class + Network.Wai.Middleware.Routes.Routes + Network.Wai.Middleware.Routes.Monad + Network.Wai.Middleware.Routes.Handler + Network.Wai.Middleware.Routes.ContentTypes + Network.Wai.Middleware.Routes.DefaultRoute + Network.Wai.Middleware.Routes.TH + Network.Wai.Middleware.Routes.TH.Types + Network.Wai.Middleware.Routes.TH.Dispatch + Network.Wai.Middleware.Routes.TH.ParseRoute + Network.Wai.Middleware.Routes.TH.RenderRoute + Network.Wai.Middleware.Routes.TH.RouteAttrs + Util.Free + exposed : True + 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 + 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.10 - , hspec >= 2.1 && < 2.3 - , hspec-wai >= 0.6 && < 0.7 - , hspec-wai-json >= 0.6 && < 0.7 - , wai-routes + build-depends : base >= 4.7 && < 4.9 + , wai >= 3.0 && < 3.1 + , aeson >= 0.8 && < 0.11 + , hspec >= 2.1 && < 2.3 + , hspec-wai >= 0.6 && < 0.7 + , hspec-wai-json >= 0.6 && < 0.7 + , wai-app-static >= 3.0 && < 3.2 + , wai-routes