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.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](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.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) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) ==================================== Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. @@ -63,7 +63,7 @@ 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) +**Example 7. Kitchen sink** - [Code](examples/kitchen) *Work in progress*. Demonstrates all major features in wai-routes. @@ -105,6 +105,7 @@ Changelog ========= +* 0.9.1 : Greatly simplified subsites (simply use mkRouteSub). Added 'mountedAppHandler' to integrate external full wai apps. * 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. 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 @@ -10,17 +10,14 @@ This package provides typesafe URLs for Wai applications. -} module Network.Wai.Middleware.Routes - ( -- * Quasi Quoters - parseRoutes -- | Parse Routes declared inline + ( -- * Declaring Routes using Template Haskell + parseRoutes , parseRoutesFile -- | Parse routes declared in a file - , parseRoutesNoCheck -- | Parse routes declared inline, without checking for overlaps - , parseRoutesFileNoCheck -- | Parse routes declared in a file, without checking for overlaps + , parseRoutesNoCheck + , parseRoutesFileNoCheck -- | Same as parseRoutesFile, but performs no overlap checking. - -- * Template Haskell methods , mkRoute - , mkRouteData - , mkRouteDispatch - , mkRouteSubDispatch + , mkRouteSub -- * Dispatch , routeDispatch @@ -64,6 +61,7 @@ -- * HandlerM Monad makes it easy to build a handler , HandlerM() , runHandlerM -- | Run a HandlerM to get a Handler + , mountedAppHandler -- | Convert a full wai application to a HandlerS , request -- | Access the request data , isWebsocket -- | Is this a websocket request , reqHeader -- | Get a particular request header (case insensitive) @@ -74,7 +72,8 @@ , 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 + , rawBody -- | Consume and return the request body as ByteString + , textBody -- | Consume and return the request body as Text , jsonBody -- | Consume and return the request body as JSON , header -- | Add a header to the response , status -- | Set the response status @@ -105,7 +104,6 @@ , module Network.HTTP.Types.Status , module Network.Wai.Middleware.RequestLogger , module Network.Wai.Application.Static - , Text ) where @@ -115,4 +113,3 @@ 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/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 @@ -13,6 +13,7 @@ module Network.Wai.Middleware.Routes.Handler ( HandlerM() -- | A Monad that makes it easier to build a Handler , runHandlerM -- | Run a HandlerM to get a Handler + , mountedAppHandler -- | Convert a full wai application to a HandlerS , request -- | Access the request data , isWebsocket -- | Is this a websocket request , reqHeader -- | Get a particular request header (case insensitive) @@ -29,7 +30,8 @@ , 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 bytestring + , rawBody -- | Consume and return the request body as ByteString + , textBody -- | Consume and return the request body as Text , jsonBody -- | Consume and return the request body as JSON , header -- | Add a header to the response , status -- | Set the response status @@ -59,7 +61,7 @@ ) where -import Network.Wai (Request, Response, responseRaw, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody, requestHeaders, FilePart) +import Network.Wai (Application, Request, Response, responseRaw, responseFile, responseBuilder, responseStream, pathInfo, queryString, requestBody, StreamingBody, requestHeaders, FilePart) #if MIN_VERSION_wai(3,0,1) import Network.Wai (strictRequestBody) #endif @@ -190,31 +192,34 @@ cookieSetHeaderName :: CI ByteString cookieSetHeaderName = mk "Set-Cookie" +-- | Convert a full wai application to a Handler +-- A bit like subsites, but at a higher level. +mountedAppHandler :: Application -> HandlerS sub master +mountedAppHandler app _env req hh = app (waiReq req) hh + -- | "Run" HandlerM, resulting in a Handler runHandlerM :: HandlerM sub master () -> HandlerS sub master runHandlerM h env req hh = do (_, st) <- runStateT (extractH h) (defaultHandlerState env req) - -- Handle cookies (add them to headers) - let cookieHeaders = map mkSetCookie (respCookies 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 + otherResponse -> do + -- Handle cookies (add them to headers) + let headers' = map mkSetCookie (respCookies st) ++ respHeaders st -- Construct the normal response - let resp = mkResponse st normalResponse + let resp = mkResponse (respStatus st) headers' otherResponse -- 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 + -- TODO: Ensure the body has not been read before using raw response + Just rawHandler -> hh $ responseRaw rawHandler resp where mkSetCookie s = (cookieSetHeaderName, toByteString $ renderSetCookie s) - 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 + mkResponse status headers (ResponseFile path part) = responseFile status headers path part + mkResponse status headers (ResponseBuilder builder) = responseBuilder status headers builder + mkResponse status headers (ResponseStream streaming) = responseStream status headers streaming -- | 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` @@ -228,6 +233,11 @@ rbody <- liftIO $ BL.toStrict <$> _readStrictRequestBody req put s {reqBody = Just rbody} return rbody + +-- | Get the request body as a Text. However consumes the entire body at once. +-- TODO: Implement streaming. Prevent clash with direct use of `Network.Wai.requestBody` +textBody :: HandlerM master master Text +textBody = liftM decodeUtf8 rawBody -- PRIVATE _readStrictRequestBody :: Request -> IO BL.ByteString 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 @@ -4,6 +4,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} {- | Module : Network.Wai.Middleware.Routes.Routes Copyright : (c) Anupam Jain 2013 @@ -24,9 +25,7 @@ -- * Template Haskell methods , mkRoute - , mkRouteData - , mkRouteDispatch - , mkRouteSubDispatch + , mkRouteSub -- * Dispatch , routeDispatch @@ -115,7 +114,7 @@ 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 +-- | Generates everything except actual dispatch mkRouteData :: String -> [ResourceTree String] -> Q [Dec] mkRouteData typName routes = do let typ = parseType typName @@ -135,8 +134,10 @@ , rinst ] -mkRouteSubDispatch :: [ResourceTree a] -> Q Exp -mkRouteSubDispatch routes = do +-- | Same as mkRouteDispatch but for subsites +mkRouteSubDispatch :: String -> String -> [ResourceTree a] -> Q [Dec] +mkRouteSubDispatch typName constraint routes = do + let typ = parseType typName disp <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [| runHandler |] , mdsSubDispatcher = [| subDispatcher |] @@ -147,16 +148,23 @@ , mds405 = [| app405 |] , mdsGetHandler = defaultGetHandler } routes - 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) + master <- newName "master" + -- We don't simply use parseType for GHC 7.8 (TH-2.9) compatibility + -- ParseType only works on Type (not Pred) + -- In GHC 7.10 (TH-2.10) onwards, Pred is aliased to Type + className <- lookupTypeName constraint + -- Check if this is a classname or a type + let contract = maybe (error $ "Unknown typeclass " ++ show constraint) (getContract master) className + return [InstanceD [contract] + (ConT ''Routable `AppT` typ `AppT` VarT master) + [FunD (mkName "dispatcher") [disp]]] + where + getContract master className = +#if MIN_VERSION_template_haskell(2,10,0) + ConT className `AppT` VarT master +#else + ClassP className [VarT master] +#endif -- | Generates a 'Routable' instance and dispatch function mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec] @@ -176,14 +184,22 @@ (ConT ''Routable `AppT` typ `AppT` typ) [FunD (mkName "dispatcher") [disp]]] --- | Generates all the things needed for efficient routing, --- including your application's `Route` datatype, and --- `RenderRoute`, `ParseRoute`, and `RouteAttr` instances, and --- `Routable` instance +-- | Generates all the things needed for efficient routing. +-- Including your application's `Route` datatype, +-- `RenderRoute`, `ParseRoute`, `RouteAttrs`, and `Routable` instances. +-- Use this for everything except subsites mkRoute :: String -> [ResourceTree String] -> Q [Dec] mkRoute typName routes = do dat <- mkRouteData typName routes disp <- mkRouteDispatch typName routes + return (disp++dat) + +-- TODO: Also allow using the master datatype name directly, instead of a constraint class +-- | Same as mkRoute, but for subsites +mkRouteSub :: String -> String -> [ResourceTree String] -> Q [Dec] +mkRouteSub typName constraint routes = do + dat <- mkRouteData typName routes + disp <- mkRouteSubDispatch typName constraint routes return (disp++dat) -- | A `Routable` instance can be used in dispatching. diff --git a/test/HelloSpec.hs b/test/HelloSpec.hs new file mode 100644 --- /dev/null +++ b/test/HelloSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} +{- + Test simple routes +-} +module HelloSpec (spec) where + +import Data.Maybe (fromMaybe) +import Network.Wai (Application) +import Network.Wai.Middleware.Routes +import Data.Aeson (Value(Number), (.=), object) + +import Data.Text (Text) +import qualified Data.Text as T + +import Test.Hspec +import Test.Hspec.Wai +import qualified Test.Hspec.Wai.JSON as H (json) + +---- A SMALL SUBSITE ---- + +data SubRoute = SubRoute + +class MasterContract master where + getMasterName :: master -> Text + +mkRouteSub "SubRoute" "MasterContract" [parseRoutes| +/ SubHomeR GET +|] + +getSubHomeR :: MasterContract master => HandlerS SubRoute master +getSubHomeR = runHandlerM $ do + m <- master + plain $ T.concat ["subsite-", getMasterName m] + +getSubRoute :: master -> SubRoute +getSubRoute = const SubRoute + + +---- THE APPLICATION TO BE TESTED ---- + +data MyRoute = MyRoute + +instance MasterContract MyRoute where + getMasterName MyRoute = "MyRoute" + +mkRoute "MyRoute" [parseRoutes| +/ HomeR GET +/some-json FooR GET +/post PostR POST +/sub SubR SubRoute getSubRoute +|] + +getHomeR :: Handler MyRoute +getHomeR = runHandlerM $ plain "hello" + +getFooR :: Handler MyRoute +getFooR = runHandlerM $ json $ object ["foo" .= Number 23, "bar" .= Number 42] + +-- Post parameters (getParam can also be used for query params) +postPostR :: Handler MyRoute +postPostR = runHandlerM $ do + name <- getParam "name" + plain $ fromMaybe "unnamed" name + +-- An example of an unrouted handler +handleInfoRequest :: Handler DefaultMaster +handleInfoRequest = runHandlerM $ do + Just (DefaultRoute (_,query)) <- maybeRoute + case lookup "info" query of + -- If an override param "info" was supplied then display info + Just _ -> plain "Info was requested - You are running wai-routes tests" + -- Else, move on to the next handler (i.e. do nothing special) + Nothing -> next + +application :: IO Application +application = return $ waiApp $ do + handler handleInfoRequest + route MyRoute + catchall $ staticApp $ defaultFileServerSettings "test/static" + + +---- THE TESTS ---- + +spec :: Spec +spec = with application $ do + describe "GET /" $ + it "responds with 'hello' and has 'Content-Type: text/plain; charset=utf-8'" $ + get "/" `shouldRespondWith` "hello" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /some-json" $ + it "responds with correct json and has 'Content-Type: application/json; charset=utf-8'" $ + get "/some-json" `shouldRespondWith` [H.json|{foo: 23, bar: 42}|] {matchStatus = 200, matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]} + + describe "GET /?info" $ + it "responds with info when requested" $ + get "/?info" `shouldRespondWith` "Info was requested - You are running wai-routes tests" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "POST /post?name=foobar" $ + it "can read query parameters" $ + postHtmlForm "/post?name=foobar" [("name","ignored")] `shouldRespondWith` "foobar" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "POST /post" $ + it "can read post body parameters" $ + postHtmlForm "/post" [("name","foobar")] `shouldRespondWith` "foobar" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /sub" $ + it "can access the subsite correctly" $ + get "/sub" `shouldRespondWith` "subsite-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /lambda.png" $ + it "returns a file correctly" $ + get "/lambda.png" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "image/png"]} + 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.9.0 +version : 0.9.1 cabal-version : >=1.18 build-type : Simple license : MIT @@ -20,8 +20,8 @@ source-repository this type : git - location : http://github.com/ajnsit/wai-routes/tree/v0.9.0 - tag : v0.9.0 + location : http://github.com/ajnsit/wai-routes/tree/v0.9.1 + tag : v0.9.1 library build-depends : base >= 4.7 && < 4.9 @@ -29,7 +29,7 @@ , wai-extra >= 3.0 && < 3.1 , wai-app-static >= 3.0 && < 3.2 , text >= 1.2 && < 1.3 - , template-haskell >= 2.9 && < 2.11 + , template-haskell >= 2.9 && < 2.12 , mtl >= 2.1 && < 2.3 , aeson >= 0.8 && < 0.11 , containers >= 0.5 && < 0.6 @@ -67,6 +67,7 @@ test-suite test main-is : Spec.hs + other-modules : HelloSpec type : exitcode-stdio-1.0 default-language : Haskell2010 hs-source-dirs : test @@ -78,5 +79,5 @@ , 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 + , text >= 1.2 && < 1.3 , wai-routes