diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,7 @@ +Copyright (c) 2012 Anupam Jain + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,141 @@ +[Helix](https://ajnsit.github.io/helix) [![Hackage](https://img.shields.io/badge/hackage-v0.9.5-brightgreen.svg)](https://hackage.haskell.org/package/helix) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/helix.svg)](http://packdeps.haskellers.com/feed?needle=helix) [![Build Status](https://img.shields.io/travis/ajnsit/helix.svg)](https://travis-ci.org/ajnsit/helix) [![Join the chat at https://gitter.im/ajnsit/helix](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/helix) +==================================== + +Helix is a micro web framework for Haskell. It was extracted from [Wai Routes](http://hackage.haskell.org/package/wai-routes) and aims to provide functionality beyond simple typesafe URLs. + +Helix 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 Helix's typesafe URL functionality was pulled from the corresponding features in [Yesod](http://www.yesodweb.com/). Helix however, adds new routing features as well such as the ability to use subsites within route hierarchies. + +Features +========== + +Helix adds the following features on top of wai - + + - Typesafe URLs, including automatic boilerplate generation using TH. Including features such as - + - 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 + - Ability to abort processing and pass control to the next application in the wai stack + - Streaming responses + + +Performance +=========== + +When it comes to performance, Helix compares quite favorably with other Haskell web development micro frameworks. + +See more details here - [philopon/apiary-benchmark](https://github.com/philopon/apiary-benchmark) + +![result](./benchmark/result-tama.png) + + +Example Usage +============= + +Helix comes with several examples in the `examples/` directory. New examples are being added regularly. + +**Example 1. Hello World** - [Code](https://github.com/ajnsit/helix/tree/master/examples/hello-world/src) + +A simple hello-world web app with two interlinked pages. This provides the simplest example of using routing and linking between pages with typesafe routes. + +**Example 2. Hello World with Subsites** - [Code](https://github.com/ajnsit/helix/tree/master/examples/subsites/src) + +Similar functionality as the first example, but uses a hello world subsites to provide the hello world functionality. A subsite is an independently developed site that can be embedded into a parent site as long as the parent site satisfies a particular api contract. It's easy to swap out subsites for different functionality as long as the api contract remains constant. + +**Example 3. Using Blaze-HTML to generate HTML** - [Code](https://github.com/ajnsit/helix/tree/master/examples/blaze-html/src) + +A simple example of how to generate HTML using blaze-html combinators in your handlers. + +**Example 4. Using Shakespearean Templates (hamlet, cassius, lucius, julius) to generate HTML/CSS/JS** - [Code](https://github.com/ajnsit/helix/tree/master/examples/shakespeare/src) + +A simple example of how to generate HTML/CSS/JS using shakespearean templates. You can use both external and inline templates. + +**Example 5. Building a JSON REST Service** - [Code](https://github.com/ajnsit/helix/tree/master/examples/rest-json/src) + +Provides a simple example of how to build JSON REST services with helix. Uses Aeson for JSON conversion. Note that this example just demonstrates the web facing side of the application. It doesn't permanently persist data, and is also not threadsafe. You must use a more robust data storage mechanism in production! An example of doing this with a Relational DB adapter (like persistent) is in the works. + +**Example 6. Stream a response** - [Code](https://github.com/ajnsit/helix/tree/master/examples/streaming-response/src) + +Wai has had the ability to stream content for a long time. Now helix 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](https://github.com/ajnsit/helix/tree/master/examples/kitchen/src) + +*Work in progress*. Demonstrates all major features in helix. + +**Example 8. Unrouted** - [Code](https://github.com/ajnsit/helix/tree/master/examples/unrouted/src) + +Demonstrates "unrouted" applications. These require no TH, or GHC extensions. Basically allow you to sequence request handlers in a cascade, with each handler having the full functionality of HandlerM monad available to them. Each handler also has access to untyped (but parsed) route information. Unrouted handlers are freely mixable with typesafe routing. + + +Deployment +========== + +The current recommended route (pun not intended) for deploying helix 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 +==================== + +The following features are planned for later releases - + +- 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 +- Scaffolding +- Better documentation, and a getting started tutorial +- More tests and code coverage + + +Changelog +========= + +* 0.9.5 : Subsites now play well with hierarchical routes +* 0.9.4 : Wai-3.2 compatibility. Added functions to manipulate wai "vault". Minor changes to internal types. +* 0.9.3 : Added `content` and `whenContent`. Allow http-types-0.9. +* 0.9.2 : Fix failing test in release tarball. (Only tests changed). +* 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. +* 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 +* 0.7.0 : Subsites support added +* 0.6.2 : Added 'maybeRoute' and 'routeAttrSet', to get information about the currently executing route +* 0.6.1 : Fixed cabal and travis files +* 0.6.0 : Removed dependency on yesod-routes. Updated code to compile with wai-3 and ghc-7.8, ghc-7.10 +* 0.5.1 : Bumped dependency upper bounds to allow text 1.* +* 0.5.0 : Added raw,text,html,json helpers. Update to wai-2.1. +* 0.4.1 : showRoute now returns "/" instead of "" +* 0.4.0 : Wai 2 compatibility. Replaced 'liftResourceT' with 'lift' +* 0.3.4 : Added 'liftResourceT' to lift a ResourceT into HandlerM +* 0.3.3 : Better exports from the Helix module +* 0.3.2 : Added HandlerM Monad which makes it easier to build Handlers +* 0.3.1 : Removed internal 'App' synonym which only muddied the types. Added common content types for convenience. +* 0.3.0 : yesod-routes 1.2 compatibility. Abstracted request data. Created `runNext` which skips to the next app in the wai stack +* 0.2.4 : Put an upper bound on yesod-routes version as 1.2 breaks API compatibility +* 0.2.3 : Implemented a better showRoute function. Added blaze-builder as a dependency +* 0.2.2 : Fixed license information in hs and cabal files +* 0.2.1 : Changed license to MIT +* 0.2 : Updated functionality based on yesod-routes package +* 0.1 : Intial release diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/helix.cabal b/helix.cabal new file mode 100644 --- /dev/null +++ b/helix.cabal @@ -0,0 +1,87 @@ +name : helix +version : 0.9.5 +cabal-version : >=1.18 +build-type : Simple +license : MIT +license-file : LICENSE +maintainer : ajnsit@gmail.com +stability : Experimental +homepage : https://ajnsit.github.io/helix/ +synopsis : Web development micro framework for haskell with typesafe URLs +description : A web development micro framework for haskell that provides easy to use typesafe URLs. See README for more information. Also see examples/ directory for usage examples. +category : Network +author : Anupam Jain +data-dir : "" +extra-source-files : README.md + , test/static/lambda.png + +source-repository head + type : git + location : http://github.com/ajnsit/helix + +source-repository this + type : git + location : http://github.com/ajnsit/helix/tree/v0.9.5 + tag : v0.9.5 + +library + build-depends : base >= 4.7 && < 4.9 + , wai >= 3.0 && < 3.3 + , wai-extra >= 3.0 && < 3.1 + , wai-app-static >= 3.0 && < 3.2 + , text >= 1.2 && < 1.3 + , template-haskell >= 2.9 && < 2.12 + , 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.10 + , 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 + , vault >= 0.3 && < 0.4 + exposed-modules : Helix + other-modules : Helix.Parse + Helix.Overlap + Helix.Class + Helix.Routes + Helix.Monad + Helix.Handler + Helix.ContentTypes + Helix.DefaultRoute + Helix.TH + Helix.TH.Types + Helix.TH.Dispatch + Helix.TH.ParseRoute + Helix.TH.RenderRoute + Helix.TH.RouteAttrs + Util.Free + exposed : True + buildable : True + hs-source-dirs : src + default-language : Haskell2010 + ghc-options : -Wall + +test-suite test + main-is : Spec.hs + other-modules : HelloSpec + 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.3 + , aeson >= 0.8 && < 0.11 + , hspec >= 2.1 && < 2.3 + , hspec-wai >= 0.6 && < 0.7 + , hspec-wai-json >= 0.6 && < 0.7 + , text >= 1.2 && < 1.3 + , helix + ghc-options : -Wall diff --git a/src/Helix.hs b/src/Helix.hs new file mode 100644 --- /dev/null +++ b/src/Helix.hs @@ -0,0 +1,118 @@ +{- | +Module : Helix +Copyright : (c) Anupam Jain 2013 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +This package provides typesafe URLs for Wai applications. +-} +module Helix + ( -- * Declaring Routes using Template Haskell + parseRoutes + , parseRoutesFile -- | Parse routes declared in a file + , parseRoutesNoCheck + , parseRoutesFileNoCheck -- | Same as parseRoutesFile, but performs no overlap checking. + + , mkRoute + , mkRouteSub + + -- * Dispatch + , routeDispatch + + -- * URL rendering and parsing + , showRouteMaster + , showRouteQueryMaster + , readRouteMaster + , showRouteSub + , showRouteQuerySub + , readRouteSub + + -- * Application Handlers + , Handler + , HandlerS + + -- * Generated Datatypes + , 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` + + -- * Accessing Raw Request Data + , 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 + + -- * Route Monad makes it easy to compose routes together + , RouteM + , DefaultMaster(..) + , Route(DefaultRoute) + , handler -- | Add a helix 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 + , route -- | Add another routed middleware to the app + , waiApp -- | Convert a RouteM to a wai Application + , toWaiApp -- | Similar to waiApp, but result is wrapped in a monad. Kept for backwards compatibility + + -- * 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) + , 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 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 + , 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 + , 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 + , css -- | Set the css response body + , 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 + , reqVault -- | Access the vault from the request + , lookupVault -- | Lookup a key in the request vault + , updateVault -- | Update the request vault + + , module Network.HTTP.Types.Status + , module Network.Wai.Middleware.RequestLogger + , module Network.Wai.Application.Static + ) + where + +import Helix.Routes +import Helix.Monad +import Helix.Handler +import Network.HTTP.Types.Status +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Application.Static diff --git a/src/Helix/Class.hs b/src/Helix/Class.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Class.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +module Helix.Class + ( RenderRoute (..) + , ParseRoute (..) + , RouteAttrs (..) + ) where + +import Data.Text (Text) +import Data.Set (Set) + +class Eq (Route a) => RenderRoute a where + -- | The associated with a site argument. + data Route a + renderRoute :: Route a + -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. + +class RenderRoute a => ParseRoute a where + parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value. + -> Maybe (Route a) + +class RenderRoute a => RouteAttrs a where + routeAttrs :: Route a + -> Set Text -- ^ A set of . diff --git a/src/Helix/ContentTypes.hs b/src/Helix/ContentTypes.hs new file mode 100644 --- /dev/null +++ b/src/Helix/ContentTypes.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} + +{- | +Module : Helix.ContentTypes +Copyright : (c) Anupam Jain 2013 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +Defines the commonly used content types +-} +module Helix.ContentTypes + ( -- * Construct content Type + acceptContentType + , contentType, contentTypeFromFile + -- * Various common content types + , typeAll + , typeHtml, typePlain, typeJson + , typeXml, typeAtom, typeRss + , typeJpeg, typePng, typeGif + , typeSvg, typeJavascript, typeCss + , typeFlv, typeOgv, typeOctet + ) + 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) + +-- | The request header for accpetable content types +acceptContentType :: HeaderName +acceptContentType = "Accept" + +-- | 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` +contentType :: HeaderName +contentType = "Content-Type" + +typeAll :: ByteString +typeAll = "*/*" + +typeHtml :: ByteString +typeHtml = "text/html; charset=utf-8" + +typePlain :: ByteString +typePlain = "text/plain; charset=utf-8" + +typeJson :: ByteString +typeJson = "application/json; charset=utf-8" + +typeXml :: ByteString +typeXml = "text/xml" + +typeAtom :: ByteString +typeAtom = "application/atom+xml" + +typeRss :: ByteString +typeRss = "application/rss+xml" + +typeJpeg :: ByteString +typeJpeg = "image/jpeg" + +typePng :: ByteString +typePng = "image/png" + +typeGif :: ByteString +typeGif = "image/gif" + +typeSvg :: ByteString +typeSvg = "image/svg+xml" + +typeJavascript :: ByteString +typeJavascript = "text/javascript; charset=utf-8" + +typeCss :: ByteString +typeCss = "text/css; charset=utf-8" + +typeFlv :: ByteString +typeFlv = "video/x-flv" + +typeOgv :: ByteString +typeOgv = "video/ogg" + +typeOctet :: ByteString +typeOctet = "application/octet-stream" + diff --git a/src/Helix/DefaultRoute.hs b/src/Helix/DefaultRoute.hs new file mode 100644 --- /dev/null +++ b/src/Helix/DefaultRoute.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | +Module : Helix.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 Helix.DefaultRoute + ( DefaultMaster(..) + , Route(DefaultRoute) + ) + where + +import Data.Text (Text) +import Data.Set (empty) + +import Helix.Routes + +-- Default master datatype, which is used for "unrouted" handlers +data DefaultMaster = DefaultMaster deriving (Eq, Show, Ord) +-- 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, Show, Ord) + renderRoute (DefaultRoute r) = r +instance ParseRoute DefaultMaster where + parseRoute = Just . DefaultRoute +instance RouteAttrs DefaultMaster where + routeAttrs = const empty diff --git a/src/Helix/Handler.hs b/src/Helix/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Handler.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} +{- | +Module : Helix.Handler +Copyright : (c) Anupam Jain 2013 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +Provides a HandlerM Monad that makes it easy to build Handlers +-} +module Helix.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) + , 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 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 + , 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 + , 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 + , css -- | Set the css response body + , javascript -- | Set the javascript response body + , content -- | Sets the response body when the content type is acceptable + , asContent -- | Set the contentType and a 'Text' body + , whenContent -- | Runs the action when a content type is acceptable + , 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 + , reqVault -- | Access the vault from the request + , lookupVault -- | Lookup a key in the request vault + , updateVault -- | Update the request vault + ) + where + +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, vault) +#endif +import Helix.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, ResponseHandler, showRoute, showRouteQuery, readRoute, readQueryString) +import Helix.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..)) +import Helix.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll) + +import Control.Monad (liftM, when) +import Control.Monad.Loops (unfoldWhileM) +import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, liftIO, MonadTrans) + +import Control.Applicative (Applicative, (<$>), (<*>)) + +import Data.Maybe (maybe, fromMaybe) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +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, 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 (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) + +import Data.CaseInsensitive (CI, mk) + +import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..)) +import Data.Default.Class (def) +import Data.List (intersect) + +import qualified Data.Vault.Lazy as V + +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 } + deriving (Applicative, Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState sub master)) + +-- | The HandlerM Monad +type HandlerM sub master a = HandlerMI sub master IO 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 ByteString + , respHeaders :: [(HeaderName, ByteString)] + , respStatus :: Status + , respResp :: Maybe 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 + , acceptCTypes :: Maybe [ByteString] + } + +-- 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 = Nothing + , respRaw = Nothing + , respCookies = [] + , getSub = envSub env + , toMasterRoute = envToMaster env + , postParams = Nothing + , acceptCTypes = Nothing + } + +-- Internal: Type of response +-- Similar to Wai's Response type +data MkResponse + = ResponseFile FilePath (Maybe FilePart) + | ResponseBuilder Builder + | ResponseStream StreamingBody + | 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" + +-- The header name for response cookies +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) + case fromMaybe defaultResponse (respResp st) of + -- Abort handling current response and move to next handler + ResponseNext -> runNext (getRequestData st) hh + -- Normal handling + otherResponse -> do + -- Handle cookies (add them to headers) + let headers' = map mkSetCookie (respCookies st) ++ respHeaders st + -- Construct the normal response + let resp = mkResponse (respStatus st) headers' otherResponse + -- Check if we are trying to send a raw response + case respRaw st of + Nothing -> hh 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 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` +rawBody :: HandlerM sub master ByteString +rawBody = do + s <- get + case reqBody s of + Just consumedBody -> return consumedBody + Nothing -> do + req <- request + 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 +_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 + BL.fromChunks <$> unfoldWhileM (not . B.null) . requestBody +#endif + +-- | Parse the body as a JSON object +jsonBody :: FromJSON a => HandlerM sub master (Either String a) +jsonBody = liftM eitherDecodeStrict rawBody + +-- | Get the 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 sub master Request +request = liftM (waiReq . getRequestData) get + +-- | Is this a websocket request +isWebsocket :: HandlerM sub master Bool +isWebsocket = liftM (maybe False (== "websocket")) (_reqHeaderBS "upgrade") + +-- | Get a particular request header (Case insensitive) +reqHeader :: Text -> HandlerM sub master (Maybe Text) +reqHeader name = liftM (fmap decodeUtf8) (_reqHeaderBS nameText) + where + nameText = mk $ encodeUtf8 name + +-- PRIVATE +_reqHeaderBS :: CI ByteString -> HandlerM sub master (Maybe ByteString) +_reqHeaderBS name = liftM (lookup name) reqHeaders + +-- VAULT +-- | Access the vault +reqVault :: HandlerM sub master V.Vault +reqVault = liftM vault request + +-- Lookup a value in the request vault +lookupVault :: V.Key a -> HandlerM sub master (Maybe a) +lookupVault k = liftM (V.lookup k) reqVault + +-- Update the request vault +-- For example: `updateVault (V.insert key val)` +updateVault :: (V.Vault -> V.Vault) -> HandlerM sub master () +updateVault f = modify $ \st -> + let rd = getRequestData st + r = waiReq rd + v = f $ vault r + in st { getRequestData = rd { waiReq = r { vault = v } } } +-- END VAULT + +-- | Get all request headers as raw case-insensitive bytestrings +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 + +-- | Get the current root route +maybeRootRoute :: HandlerM sub master (Maybe (Route master)) +maybeRootRoute = do + s <- get + return $ toMasterRoute s <$> currentRoute (getRequestData s) + +-- | Get the route rendering function for the master site +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 -> 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 -> [(Text,Text)] -> Text) +showRouteQueryMaster = return showRouteQuery + +-- | Get the route rendering function for the subsite +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 (Text -> Maybe (Route master)) +readRouteMaster = return readRoute + +-- | Get the route parsing function for the subsite +readRouteSub :: ParseRoute sub => HandlerM sub master (Text -> Maybe (Route master)) +readRouteSub = do + s <- get + return $ (toMasterRoute s <$>) . readRoute + +-- | Get the current route attributes +routeAttrSet :: RouteAttrs sub => HandlerM sub master (Set Text) +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 $ 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 sub master () +header h s = modify $ addHeader h s + where + 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 sub master () +status s = modify $ setStatus s + where + setStatus :: Status -> HandlerState sub master -> HandlerState sub master + setStatus s st = st{respStatus=s} + +-- | Send a file as response +file :: FilePath -> HandlerM sub master () +file f = do + header contentType $ contentTypeFromFile f + modify addFile + where + 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 s + +-- | Set the response body +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 b + +-- | Run the next application +next :: HandlerM sub master () +next = modify rNext + where + rNext st = _setResp st ResponseNext + +-- Util +-- Set the response handler (don't overwrite an existing response) +_setResp :: HandlerState sub master -> MkResponse -> HandlerState sub master +_setResp st r = case respResp st of + Nothing -> st{respResp=Just r} + _ -> st + + +-- 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 sub master () +-- TODO: Use Accept header parsing +-- json a = whenContent [typeJson, typeJavascript, typePlain] $ do +json a = do + header contentType typeJson + 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\". +plain :: Text -> HandlerM sub master () +-- TODO: Use Accept header parsing +-- plain = content [typePlain] +plain = asContent typePlain + +-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" +-- header to \"text/html\". +html :: Text -> HandlerM sub master () +-- TODO: Use Accept header parsing +-- html = content [typeHtml, typePlain] +html = asContent typeHtml + +-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" +-- header to \"text/css\". +css :: Text -> HandlerM sub master () +-- TODO: Use Accept header parsing +-- css = content [typeCss, typePlain] +css = asContent typeCss + +-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\" +-- header to \"text/javascript\". +javascript :: Text -> HandlerM sub master () +-- TODO: Use Accept header parsing +-- javascript = content [typeJavascript, typePlain] +javascript = asContent typeJavascript + +-- | Sets the content-type header to the given Bytestring +-- (look in Helix.ContentTypes for examples) +-- And sets the body of the response to the given Text +asContent :: ByteString -> Text -> HandlerM sub master () +asContent ctype content = do + header contentType ctype + raw $ encodeUtf8 content + +-- | Sets the response body when the content type is acceptable +content :: [ByteString] -> Text -> HandlerM sub master () +content [] _ = return () +content ctypes content = whenContent ctypes (asContent (head ctypes) content) + +-- | Perform an action only when there is no accept list or the given contentType is acceptable +whenContent :: [ByteString] -> HandlerM sub master () -> HandlerM sub master () +whenContent ctypes respHandler = do + atypes <- acceptableContentTypes + let noAcceptList = not $ null atypes + let acceptableTypeFound = not $ null $ intersect (typeAll:ctypes) atypes + when (noAcceptList || acceptableTypeFound) respHandler + +-- | Get a list of content types acceptable to the request +acceptableContentTypes :: HandlerM sub master [ByteString] +acceptableContentTypes = do + st <- get + maybe (getCTypes st) return (acceptCTypes st) + where + getCTypes st = do + h <- _reqHeaderBS acceptContentType + let parsedCTypes = maybe [] P.parseHttpAccept h + put st{acceptCTypes = Just parsedCTypes} + return parsedCTypes + +-- | 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 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 <- _reqHeaderBS cookieHeaderName + return $ case cookies of + Nothing -> [] + Just cookies' -> parseCookiesText cookies' + +-- | Get a particular cookie +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/Helix/Monad.hs b/src/Helix/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Monad.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-} + +{- | +Module : Helix.Monad +Copyright : (c) Anupam Jain 2013 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +Defines a Routing Monad that provides easy composition of Routes +-} +module Helix.Monad + ( -- * Route Monad + RouteM + -- * Compose Routes + , DefaultMaster(..) + , Route(DefaultRoute) + , handler + , middleware + , route + , catchall + , defaultAction + -- * Convert to Wai Application + , waiApp + , toWaiApp + ) + where + +import Network.Wai +import Helix.Routes +import Helix.DefaultRoute +import Network.HTTP.Types (status404) + +import Util.Free (F(..), liftF) + +-- A Router functor can either add a middleware, or resolve to an app itself. +data RouterF x = M Middleware x | D Application deriving Functor + +-- Router type +type RouteM = F RouterF + +-- | Catch all routes and process them with the supplied application. +-- Note: As expected from the name, no request proceeds past a catchall. +catchall :: Application -> RouteM () +catchall a = liftF $ D a + +-- | Synonym of `catchall`. Kept for backwards compatibility +defaultAction :: Application -> RouteM () +defaultAction = catchall + +-- | Add a middleware to the application +-- Middleware are ordered so the one declared earlier wraps the ones later +middleware :: Middleware -> RouteM () +middleware m = liftF $ M m () + +-- | Add a helix handler +handler :: HandlerS DefaultMaster 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 () +route = middleware . routeDispatch + +-- The final "catchall" application, simply returns a 404 response +-- Ideally you should put your own default application +defaultApplication :: Application +defaultApplication _req h = h $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found" + +-- | Convert a RouteM monad into a wai application. +-- Note: We ignore the return type of the monad +waiApp :: RouteM () -> Application +waiApp (F r) = r (const defaultApplication) f + where + f (M m r') = m r' + f (D a) = a + +-- | Similar to waiApp but returns the app in an arbitrary monad +-- Kept for backwards compatibility +toWaiApp :: Monad m => RouteM () -> m Application +toWaiApp = return . waiApp diff --git a/src/Helix/Overlap.hs b/src/Helix/Overlap.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Overlap.hs @@ -0,0 +1,88 @@ +-- | Check for overlapping routes. +module Helix.Overlap + ( findOverlapNames + , Overlap (..) + ) where + +import Helix.TH.Types +import Data.List (intercalate) + +data Flattened t = Flattened + { fNames :: [String] + , fPieces :: [Piece t] + , fHasSuffix :: Bool + , fCheck :: CheckOverlap + } + +flatten :: ResourceTree t -> [Flattened t] +flatten = + go id id True + where + go names pieces check (ResourceLeaf r) = return Flattened + { fNames = names [resourceName r] + , fPieces = pieces (resourcePieces r) + , fHasSuffix = hasSuffix $ ResourceLeaf r + , fCheck = check && resourceCheck r + } + go names pieces check (ResourceParent newname check' newpieces children) = + concatMap (go names' pieces' (check && check')) children + where + names' = names . (newname:) + pieces' = pieces . (newpieces ++) + +data Overlap t = Overlap + { overlapParents :: [String] -> [String] -- ^ parent resource trees + , overlap1 :: ResourceTree t + , overlap2 :: ResourceTree t + } + +data OverlapF = OverlapF + { _overlapF1 :: [String] + , _overlapF2 :: [String] + } + +overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool + +-- No pieces on either side, will overlap regardless of suffix +overlaps [] [] _ _ = True + +-- No pieces on the left, will overlap if the left side has a suffix +overlaps [] _ suffixX _ = suffixX + +-- Ditto for the right +overlaps _ [] _ suffixY = suffixY + +-- Compare the actual pieces +overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY = + piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY + +piecesOverlap :: Piece t -> Piece t -> Bool +-- Statics only match if they equal. Dynamics match with anything +piecesOverlap (Static x) (Static y) = x == y +piecesOverlap _ _ = True + +findOverlapNames :: [ResourceTree t] -> [(String, String)] +findOverlapNames = + map go . findOverlapsF . filter fCheck . concatMap Helix.Overlap.flatten + where + go (OverlapF x y) = + (go' x, go' y) + where + go' = intercalate "/" + +findOverlapsF :: [Flattened t] -> [OverlapF] +findOverlapsF [] = [] +findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs + +findOverlapF :: Flattened t -> Flattened t -> [OverlapF] +findOverlapF x y + | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)] + | otherwise = [] + +hasSuffix :: ResourceTree t -> Bool +hasSuffix (ResourceLeaf r) = + case resourceDispatch r of + Subsite{} -> True + Methods Just{} _ -> True + Methods Nothing _ -> False +hasSuffix ResourceParent{} = True diff --git a/src/Helix/Parse.hs b/src/Helix/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Parse.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter +module Helix.Parse + ( parseRoutes + , parseRoutesFile + , parseRoutesNoCheck + , parseRoutesFileNoCheck + , parseType + , parseTypeTree + , TypeTree (..) + ) where + +import Language.Haskell.TH.Syntax +import Data.Char (isUpper) +import Language.Haskell.TH.Quote +import qualified System.IO as SIO +import Helix.TH +import Helix.Overlap (findOverlapNames) +import Data.List (foldl') +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set + +-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for +-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the +-- checking. See documentation site for details on syntax. +parseRoutes :: QuasiQuoter +parseRoutes = QuasiQuoter { quoteExp = x } + where + x s = do + let res = resourcesFromString s + case findOverlapNames res of + [] -> lift res + z -> error $ unlines $ "Overlapping routes: " : map show z + +parseRoutesFile :: FilePath -> Q Exp +parseRoutesFile = parseRoutesFileWith parseRoutes + +parseRoutesFileNoCheck :: FilePath -> Q Exp +parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck + +parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp +parseRoutesFileWith qq fp = do + qAddDependentFile fp + s <- qRunIO $ readUtf8File fp + quoteExp qq s + +readUtf8File :: FilePath -> IO String +readUtf8File fp = do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + SIO.hGetContents h + +-- | Same as 'parseRoutes', but performs no overlap checking. +parseRoutesNoCheck :: QuasiQuoter +parseRoutesNoCheck = QuasiQuoter + { quoteExp = lift . resourcesFromString + } + +-- | Convert a multi-line string to a set of resources. See documentation for +-- the format of this string. This is a partial function which calls 'error' on +-- invalid input. +resourcesFromString :: String -> [ResourceTree String] +resourcesFromString = + fst . parse 0 . filter (not . all (== ' ')) . lines + where + parse _ [] = ([], []) + parse indent (thisLine:otherLines) + | length spaces < indent = ([], thisLine : otherLines) + | otherwise = (this others, remainder) + where + parseAttr ('!':x) = Just x + parseAttr _ = Nothing + + stripColonLast = + go id + where + go _ [] = Nothing + go front [x] + | null x = Nothing + | last x == ':' = Just $ front [init x] + | otherwise = Nothing + go front (x:xs) = go (front . (x:)) xs + + spaces = takeWhile (== ' ') thisLine + (others, remainder) = parse indent otherLines' + (this, otherLines') = + case takeWhile (/= "--") $ words thisLine of + (pattern:rest0) + | Just (constr:rest) <- stripColonLast rest0 + , Just attrs <- mapM parseAttr rest -> + let (children, otherLines'') = parse (length spaces + 1) otherLines + children' = addAttrs attrs children + (pieces, Nothing, check) = piecesFromStringCheck pattern + in ((ResourceParent constr check pieces children' :), otherLines'') + (pattern:constr:rest) -> + let (pieces, mmulti, check) = piecesFromStringCheck pattern + (attrs, rest') = takeAttrs rest + disp = dispatchFromString rest' mmulti + in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines) + [] -> (id, otherLines) + _ -> error $ "Invalid resource line: " ++ thisLine + +piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) +piecesFromStringCheck s0 = + (pieces, mmulti, check) + where + (s1, check1) = stripBang s0 + (pieces', mmulti') = piecesFromString $ drop1Slash s1 + pieces = map snd pieces' + mmulti = fmap snd mmulti' + check = check1 && all fst pieces' && maybe True fst mmulti' + + stripBang ('!':rest) = (rest, False) + stripBang x = (x, True) + +addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String] +addAttrs attrs = + map goTree + where + goTree (ResourceLeaf res) = ResourceLeaf (goRes res) + goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z) + + goRes res = + res { resourceAttrs = noDupes ++ resourceAttrs res } + where + usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res + used attr = + case toPair attr of + Nothing -> False + Just (key, _) -> key `Set.member` usedKeys + noDupes = filter (not . used) attrs + + toPair s = + case break (== '=') s of + (x, '=':y) -> Just (x, y) + _ -> Nothing + +-- | Take attributes out of the list and put them in the first slot in the +-- result tuple. +takeAttrs :: [String] -> ([String], [String]) +takeAttrs = + go id id + where + go x y [] = (x [], y []) + go x y (('!':attr):rest) = go (x . (attr:)) y rest + go x y (z:rest) = go x (y . (z:)) rest + +dispatchFromString :: [String] -> Maybe String -> Dispatch String +dispatchFromString rest mmulti + | null rest = Methods mmulti [] + | all (all isUpper) rest = Methods mmulti rest +dispatchFromString [subTyp, subFun] Nothing = + Subsite subTyp subFun +dispatchFromString [_, _] Just{} = + error "Subsites cannot have a multipiece" +dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest + +drop1Slash :: String -> String +drop1Slash ('/':x) = x +drop1Slash x = x + +piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String)) +piecesFromString "" = ([], Nothing) +piecesFromString x = + case (this, rest) of + (Left typ, ([], Nothing)) -> ([], Just typ) + (Left _, _) -> error "Multipiece must be last piece" + (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) + where + (y, z) = break (== '/') x + this = pieceFromString y + rest = piecesFromString $ drop 1 z + +parseType :: String -> Type +parseType orig = + maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig + +parseTypeTree :: String -> Maybe TypeTree +parseTypeTree orig = + toTypeTree pieces + where + pieces = filter (not . null) $ splitOn '-' $ addDashes orig + addDashes [] = [] + addDashes (x:xs) = + front $ addDashes xs + where + front rest + | x `elem` "()[]" = '-' : x : '-' : rest + | otherwise = x : rest + splitOn c s = + case y' of + _:y -> x : splitOn c y + [] -> [x] + where + (x, y') = break (== c) s + +data TypeTree = TTTerm String + | TTApp TypeTree TypeTree + | TTList TypeTree + deriving (Show, Eq) + +toTypeTree :: [String] -> Maybe TypeTree +toTypeTree orig = do + (x, []) <- gos orig + return x + where + go [] = Nothing + go ("(":xs) = do + (x, rest) <- gos xs + case rest of + ")":rest' -> Just (x, rest') + _ -> Nothing + go ("[":xs) = do + (x, rest) <- gos xs + case rest of + "]":rest' -> Just (TTList x, rest') + _ -> Nothing + go (x:xs) = Just (TTTerm x, xs) + + gos xs1 = do + (t, xs2) <- go xs1 + (ts, xs3) <- gos' id xs2 + Just (foldl' TTApp t ts, xs3) + + gos' front [] = Just (front [], []) + gos' front (x:xs) + | x `elem` words ") ]" = Just (front [], x:xs) + | otherwise = do + (t, xs') <- go $ x:xs + gos' (front . (t:)) xs' + +ttToType :: TypeTree -> Type +ttToType (TTTerm s) = ConT $ mkName s +ttToType (TTApp x y) = ttToType x `AppT` ttToType y +ttToType (TTList t) = ListT `AppT` ttToType t + +pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) +pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) +pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right $ (True, Dynamic x) + +pieceFromString ('*':'!':x) = Left (False, x) +pieceFromString ('+':'!':x) = Left (False, x) + +pieceFromString ('!':'*':x) = Left (False, x) +pieceFromString ('!':'+':x) = Left (False, x) + +pieceFromString ('*':x) = Left (True, x) +pieceFromString ('+':x) = Left (True, x) + +pieceFromString ('!':x) = Right $ (False, Static x) +pieceFromString x = Right $ (True, Static x) diff --git a/src/Helix/Routes.hs b/src/Helix/Routes.hs new file mode 100644 --- /dev/null +++ b/src/Helix/Routes.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{- | +Module : Helix.Routes +Copyright : (c) Anupam Jain 2013 +License : MIT (see the file LICENSE) + +Maintainer : ajnsit@gmail.com +Stability : experimental +Portability : non-portable (uses ghc extensions) + +This package provides typesafe URLs for Wai applications. +-} +module Helix.Routes + ( -- * Quasi Quoters + parseRoutes -- | Parse Routes declared inline + , 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 + + -- * Template Haskell methods + , mkRoute + , mkRouteSub + + -- * Dispatch + , routeDispatch + , customRouteDispatch + + -- * URL rendering and parsing + , showRoute + , showRouteQuery + , readRoute + + -- * Application Handlers + , Handler + , HandlerS + + -- * As of Wai 3, Application datatype now follows continuation passing style + -- A `ResponseHandler` represents a continuation passed to the application + , ResponseHandler + + -- * Generated Datatypes + , 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` + + -- * 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 + , currentRoute -- | Extract the current `Route` from `RequestData` + , runNext -- | Run the next application in the stack + + -- * Not exported outside helix + , runHandler + , readQueryString + ) + where + +-- Wai +import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..)) +import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText) + +-- Helix +import Helix.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..)) +import Helix.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType) +import Helix.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) + +-- TH +import Language.Haskell.TH.Syntax + +-- Convenience +import Control.Arrow (second) +import Data.Maybe (fromMaybe) + +-- An abstract request +data RequestData master = RequestData + { waiReq :: Request + , nextApp :: Application + , currentRoute :: Maybe (Route master) + } + +-- 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 sub = forall master. RenderRoute master => HandlerS sub master +type HandlerS sub master = Env sub master -> App sub + +-- | Generates everything except actual dispatch +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 + ] + +-- | Generates a 'Routable' instance and dispatch function +mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec] +mkRouteDispatch typName routes = do + let typ = parseType typName + disp <- mkRouteDispatchClause routes + return [InstanceD [] + (ConT ''Routable `AppT` typ `AppT` typ) + [FunD (mkName "dispatcher") [disp]]] + +-- | Same as mkRouteDispatch but for subsites +mkRouteSubDispatch :: String -> String -> [ResourceTree a] -> Q [Dec] +mkRouteSubDispatch typName constraint routes = do + let typ = parseType typName + disp <- mkRouteDispatchClause routes + 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 + +-- Helper that creates the dispatch clause +mkRouteDispatchClause :: [ResourceTree a] -> Q Clause +mkRouteDispatchClause routes = + mkDispatchClause MkDispatchSettings + { mdsRunHandler = [| runHandler |] + , mdsSubDispatcher = [| subDispatcher |] + , mdsGetPathInfo = [| getPathInfo |] + , mdsMethod = [| getReqMethod |] + , mdsSetPathInfo = [| setPathInfo |] + , mds404 = [| app404 |] + , mds405 = [| app405 |] + , mdsGetHandler = defaultGetHandler + } routes + + +-- | 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. +-- An appropriate instance for your site datatype is +-- 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 => 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 +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 +showRouteQuery r q = uncurry _encodePathInfo $ second (map (second Just) . (++ q)) $ renderRoute r + +-- | Renders a `Route` as Text +showRoute :: RenderRoute master => Route master -> Text +showRoute = uncurry _encodePathInfo . second (map $ second Just) . renderRoute + +_encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text +-- Slightly hackish: Convert "" into "/" +_encodePathInfo [] = _encodePathInfo [""] +_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 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 +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 +-- 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 + -> 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 diff --git a/src/Helix/TH.hs b/src/Helix/TH.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module Helix.TH + ( module Helix.TH.Types + -- * Functions + , module Helix.TH.RenderRoute + , module Helix.TH.ParseRoute + , module Helix.TH.RouteAttrs + -- ** Dispatch + , module Helix.TH.Dispatch + ) where + +import Helix.TH.Types +import Helix.TH.RenderRoute +import Helix.TH.ParseRoute +import Helix.TH.RouteAttrs +import Helix.TH.Dispatch diff --git a/src/Helix/TH/Dispatch.hs b/src/Helix/TH/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH/Dispatch.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} +module Helix.TH.Dispatch + ( MkDispatchSettings (..) + , mkDispatchClause + , defaultGetHandler + ) where + +import Prelude hiding (exp) +import Language.Haskell.TH.Syntax +import Web.PathPieces +import Data.Maybe (catMaybes) +import Control.Monad (forM) +import Data.List (foldl') +import Control.Arrow (second) +import System.Random (randomRIO) +import Helix.TH.Types +import Data.Char (toLower) + +data MkDispatchSettings = MkDispatchSettings + { mdsRunHandler :: Q Exp + , mdsSubDispatcher :: Q Exp + , mdsGetPathInfo :: Q Exp + , mdsSetPathInfo :: Q Exp + , mdsMethod :: Q Exp + , mds404 :: Q Exp + , mds405 :: Q Exp + , mdsGetHandler :: Maybe String -> String -> Q Exp + } + +data SDC = SDC + { clause404 :: Clause + , extraParams :: [Exp] + , extraCons :: [Exp] + , envExp :: Exp + , reqExp :: Exp + } + +-- | A simpler version of Helix.TH.Dispatch.mkDispatchClause, based on +-- view patterns. +-- +-- Since 1.4.0 +mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkDispatchClause MkDispatchSettings {..} resources = do + suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) + envName <- newName $ "env" ++ show suffix + reqName <- newName $ "req" ++ show suffix + helperName <- newName $ "helper" ++ show suffix + + let envE = VarE envName + reqE = VarE reqName + helperE = VarE helperName + + clause404' <- mkClause404 envE reqE + getPathInfo <- mdsGetPathInfo + let pathInfo = getPathInfo `AppE` reqE + + let sdc = SDC + { clause404 = clause404' + , extraParams = [] + , extraCons = [] + , envExp = envE + , reqExp = reqE + } + clauses <- mapM (go sdc) resources + + return $ Clause + [VarP envName, VarP reqName] + (NormalB $ helperE `AppE` pathInfo) + [FunD helperName $ clauses ++ [clause404']] + where + handlePiece :: Piece a -> Q (Pat, Maybe Exp) + handlePiece (Static str) = return (LitP $ StringL str, Nothing) + handlePiece (Dynamic _) = do + x <- newName "dyn" + let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + return (pat, Just $ VarE x) + + handlePieces :: [Piece a] -> Q ([Pat], [Exp]) + handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece + + mkCon :: String -> [Exp] -> Exp + mkCon name = foldl' AppE (ConE $ mkName name) + + mkPathPat :: Pat -> [Pat] -> Pat + mkPathPat final = + foldr addPat final + where + addPat x y = ConP '(:) [x, y] + + go :: SDC -> ResourceTree a -> Q Clause + go sdc (ResourceParent name _check pieces children) = do + (pats, dyns) <- handlePieces pieces + let sdc' = sdc + { extraParams = extraParams sdc ++ dyns + , extraCons = extraCons sdc ++ [mkCon name dyns] + } + childClauses <- mapM (go sdc') children + + restName <- newName "rest" + let restE = VarE restName + restP = VarP restName + + helperName <- newName $ "helper" ++ name + let helperE = VarE helperName + + return $ Clause + [mkPathPat restP pats] + (NormalB $ helperE `AppE` restE) + [FunD helperName $ childClauses ++ [clause404 sdc]] + go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do + (pats, dyns) <- handlePieces pieces + + (chooseMethod, finalPat) <- handleDispatch dispatch dyns + + return $ Clause + [mkPathPat finalPat pats] + (NormalB chooseMethod) + [] + where + handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat) + handleDispatch dispatch' dyns = + case dispatch' of + Methods multi methods -> do + (finalPat, mfinalE) <- + case multi of + Nothing -> return (ConP '[] [], Nothing) + Just _ -> do + multiName <- newName "multi" + let pat = ViewP (VarE 'fromPathMultiPiece) + (ConP 'Just [VarP multiName]) + return (pat, Just $ VarE multiName) + + let dynsMulti = + case mfinalE of + Nothing -> dyns + Just e -> dyns ++ [e] + route' = foldl' AppE (ConE (mkName name)) dynsMulti + route = foldr AppE route' extraCons + jroute = ConE 'Just `AppE` route + allDyns = extraParams ++ dynsMulti + mkRunExp mmethod = do + runHandlerE <- mdsRunHandler + handlerE' <- mdsGetHandler mmethod name + let handlerE = foldl' AppE handlerE' allDyns + return $ runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + + func <- + case methods of + [] -> mkRunExp Nothing + _ -> do + getMethod <- mdsMethod + let methodE = getMethod `AppE` reqExp + matches <- forM methods $ \method -> do + exp <- mkRunExp (Just method) + return $ Match (LitP $ StringL method) (NormalB exp) [] + match405 <- do + runHandlerE <- mdsRunHandler + handlerE <- mds405 + let exp = runHandlerE + `AppE` handlerE + `AppE` envExp + `AppE` jroute + `AppE` reqExp + return $ Match WildP (NormalB exp) [] + return $ CaseE methodE $ matches ++ [match405] + + return (func, finalPat) + Subsite _ getSub -> do + restPath <- newName "restPath" + setPathInfoE <- mdsSetPathInfo + subDispatcherE <- mdsSubDispatcher + runHandlerE <- mdsRunHandler + sub <- newName "sub" + let sub2 = LamE [VarP sub] + (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) + let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp + route' = foldl' AppE (ConE (mkName name)) dyns + -- Subsites didn't work with hierarchical routes earlier + sroute = mkName "sroute" + route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons + exp = subDispatcherE + `AppE` runHandlerE + `AppE` sub2 + `AppE` route + `AppE` envExp + `AppE` reqExp' + return (exp, VarP restPath) + + mkClause404 envE reqE = do + handler <- mds404 + runHandler <- mdsRunHandler + let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE + return $ Clause [WildP] (NormalB exp) [] + +defaultGetHandler :: Maybe String -> String -> Q Exp +defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s +defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s diff --git a/src/Helix/TH/ParseRoute.hs b/src/Helix/TH/ParseRoute.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH/ParseRoute.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +module Helix.TH.ParseRoute + ( -- ** ParseRoute + mkParseRouteInstance + ) where + +import Helix.TH.Types +import Language.Haskell.TH.Syntax +import Data.Text (Text) +import Helix.Class +import Helix.TH.Dispatch + +mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec +mkParseRouteInstance typ ress = do + cls <- mkDispatchClause + MkDispatchSettings + { mdsRunHandler = [|\_ _ x _ -> x|] + , mds404 = [|error "mds404"|] + , mds405 = [|error "mds405"|] + , mdsGetPathInfo = [|fst|] + , mdsMethod = [|error "mdsMethod"|] + , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] + , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] + , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] + } + (map removeMethods ress) + helper <- newName "helper" + fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] + return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) + [ FunD 'parseRoute $ return $ Clause + [] + (NormalB $ fixer `AppE` VarE helper) + [FunD helper [cls]] + ] + where + -- We do this in order to ski the unnecessary method parsing + removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res + removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z + + removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res } + + fixDispatch (Methods x _) = Methods x [] + fixDispatch x = x diff --git a/src/Helix/TH/RenderRoute.hs b/src/Helix/TH/RenderRoute.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH/RenderRoute.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +module Helix.TH.RenderRoute + ( -- ** RenderRoute + mkRenderRouteInstance + , mkRenderRouteInstance' + , mkRouteCons + , mkRenderRouteClauses + ) where + +import Helix.TH.Types +import Language.Haskell.TH.Syntax +import Data.Maybe (maybeToList) +import Control.Monad (replicateM) +import Data.Text (pack) +import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) +import Helix.Class +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mconcat) +#endif + +-- | Generate the constructors of a route data type. +mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) +mkRouteCons = + mconcat . map mkRouteCon + where + mkRouteCon (ResourceLeaf res) = + ([con], []) + where + con = NormalC (mkName $ resourceName res) + $ map (\x -> (NotStrict, x)) + $ concat [singles, multi, sub] + singles = concatMap toSingle $ resourcePieces res + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + + multi = maybeToList $ resourceMulti res + + sub = + case resourceDispatch res of + Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] + _ -> [] + mkRouteCon (ResourceParent name _check pieces children) = + ([con], dec : decs) + where + (cons, decs) = mkRouteCons children + con = NormalC (mkName name) + $ map (\x -> (NotStrict, x)) + $ concat [singles, [ConT $ mkName name]] + dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] + + singles = concatMap toSingle pieces + toSingle Static{} = [] + toSingle (Dynamic typ) = [typ] + +-- | Clauses for the 'renderRoute' method. +mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] +mkRenderRouteClauses = + mapM go + where + isDynamic Dynamic{} = True + isDynamic _ = False + + go (ResourceParent name _check pieces children) = do + let cnt = length $ filter isDynamic pieces + dyns <- replicateM cnt $ newName "dyn" + child <- newName "child" + let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns + + childRender <- newName "childRender" + let rr = VarE childRender + childClauses <- mkRenderRouteClauses children + + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces' = foldr cons (VarE a) piecesSingle + + let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child) + + return $ Clause [pat] (NormalB body) [FunD childRender childClauses] + + go (ResourceLeaf res) = do + let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res) + dyns <- replicateM cnt $ newName "dyn" + sub <- + case resourceDispatch res of + Subsite{} -> fmap return $ newName "sub" + _ -> return [] + let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub + + pack' <- [|pack|] + tsp <- [|toPathPiece|] + let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns + + piecesMulti <- + case resourceMulti res of + Nothing -> return $ ListE [] + Just{} -> do + tmp <- [|toPathMultiPiece|] + return $ tmp `AppE` VarE (last dyns) + + body <- + case sub of + [x] -> do + rr <- [|renderRoute|] + a <- newName "a" + b <- newName "b" + + colon <- [|(:)|] + let cons y ys = InfixE (Just y) colon (Just ys) + let pieces = foldr cons (VarE a) piecesSingle + + return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x) + _ -> do + colon <- [|(:)|] + let cons a b = InfixE (Just a) colon (Just b) + return $ TupE [foldr cons piecesMulti piecesSingle, ListE []] + + return $ Clause [pat] (NormalB body) [] + + mkPieces _ _ [] _ = [] + mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns + mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns + mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120" + +-- | Generate the 'RenderRoute' instance. +-- +-- This includes both the 'Route' associated type and the +-- 'renderRoute' method. This function uses both 'mkRouteCons' and +-- 'mkRenderRouteClasses'. +mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstance = mkRenderRouteInstance' [] + +-- | A more general version of 'mkRenderRouteInstance' which takes an +-- additional context. + +mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstance' cxt typ ress = do + cls <- mkRenderRouteClauses ress + let (cons, decs) = mkRouteCons ress + return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ) + [ DataInstD [] ''Route [typ] cons clazzes + , FunD (mkName "renderRoute") cls + ] : decs + where + clazzes = [''Show, ''Eq, ''Read] diff --git a/src/Helix/TH/RouteAttrs.hs b/src/Helix/TH/RouteAttrs.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH/RouteAttrs.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +module Helix.TH.RouteAttrs + ( mkRouteAttrsInstance + ) where + +import Helix.TH.Types +import Helix.Class +import Language.Haskell.TH.Syntax +import Data.Set (fromList) +import Data.Text (pack) + +mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec +mkRouteAttrsInstance typ ress = do + clauses <- mapM (goTree id) ress + return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ) + [ FunD 'routeAttrs $ concat clauses + ] + +goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause] +goTree front (ResourceLeaf res) = fmap return $ goRes front res +goTree front (ResourceParent name _check pieces trees) = + fmap concat $ mapM (goTree front') trees + where + ignored = ((replicate toIgnore WildP ++) . return) + toIgnore = length $ filter isDynamic pieces + isDynamic Dynamic{} = True + isDynamic Static{} = False + front' = front . ConP (mkName name) . ignored + +goRes :: (Pat -> Pat) -> Resource a -> Q Clause +goRes front Resource {..} = + return $ Clause + [front $ RecP (mkName resourceName) []] + (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs)) + [] + where + toText s = VarE 'pack `AppE` LitE (StringL s) diff --git a/src/Helix/TH/Types.hs b/src/Helix/TH/Types.hs new file mode 100644 --- /dev/null +++ b/src/Helix/TH/Types.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Warning! This module is considered internal and may have breaking changes +module Helix.TH.Types + ( -- * Data types + Resource (..) + , ResourceTree (..) + , Piece (..) + , Dispatch (..) + , CheckOverlap + , FlatResource (..) + -- ** Helper functions + , resourceMulti + , resourceTreePieces + , resourceTreeName + , flatten + ) where + +import Language.Haskell.TH.Syntax + +data ResourceTree typ + = ResourceLeaf (Resource typ) + | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ] + deriving Functor + +resourceTreePieces :: ResourceTree typ -> [Piece typ] +resourceTreePieces (ResourceLeaf r) = resourcePieces r +resourceTreePieces (ResourceParent _ _ x _) = x + +resourceTreeName :: ResourceTree typ -> String +resourceTreeName (ResourceLeaf r) = resourceName r +resourceTreeName (ResourceParent x _ _ _) = x + +instance Lift t => Lift (ResourceTree t) where + lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|] + lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|] + +data Resource typ = Resource + { resourceName :: String + , resourcePieces :: [Piece typ] + , resourceDispatch :: Dispatch typ + , resourceAttrs :: [String] + , resourceCheck :: CheckOverlap + } + deriving (Show, Functor) + +type CheckOverlap = Bool + +instance Lift t => Lift (Resource t) where + lift (Resource a b c d e) = [|Resource a b c d e|] + +data Piece typ = Static String | Dynamic typ + deriving Show + +instance Functor Piece where + fmap _ (Static s) = (Static s) + fmap f (Dynamic t) = Dynamic (f t) + +instance Lift t => Lift (Piece t) where + lift (Static s) = [|Static $(lift s)|] + lift (Dynamic t) = [|Dynamic $(lift t)|] + +data Dispatch typ = + Methods + { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end + , methodsMethods :: [String] -- ^ supported request methods + } + | Subsite + { subsiteType :: typ + , subsiteFunc :: String + } + deriving Show + +instance Functor Dispatch where + fmap f (Methods a b) = Methods (fmap f a) b + fmap f (Subsite a b) = Subsite (f a) b + +instance Lift t => Lift (Dispatch t) where + lift (Methods Nothing b) = [|Methods Nothing $(lift b)|] + lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|] + lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|] + +resourceMulti :: Resource typ -> Maybe typ +resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t +resourceMulti _ = Nothing + +data FlatResource a = FlatResource + { frParentPieces :: [(String, [Piece a])] + , frName :: String + , frPieces :: [Piece a] + , frDispatch :: Dispatch a + , frCheck :: Bool + } + +flatten :: [ResourceTree a] -> [FlatResource a] +flatten = + concatMap (go id True) + where + go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)] + go front check' (ResourceParent name check pieces children) = + concatMap (go (front . ((name, pieces):)) (check && check')) children diff --git a/src/Util/Free.hs b/src/Util/Free.hs new file mode 100644 --- /dev/null +++ b/src/Util/Free.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes, DeriveFunctor #-} +module Util.Free ( + F(..), + liftF +) where + +import Control.Applicative (Applicative, (<*>), pure) + +-- Free Monad +newtype F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r } +instance Functor f => Functor (F f) where + fmap f (F g) = F (\kp -> g (kp . f)) +instance Functor f => Applicative (F f) where + pure a = F (\kp _ -> kp a) + F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf) +instance Functor f => Monad (F f) where + return a = F (\kp _ -> kp a) + F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf) + +-- | Add a layer +wrap :: Functor f => f (F f a) -> F f a +wrap f = F (\kp kf -> kf (fmap (\ (F m) -> m kp kf) f)) + +-- | A version of lift that can be used with just a Functor for f. +liftF :: Functor f => f a -> F f a +liftF = wrap . fmap return +-- End free monad things diff --git a/test/HelloSpec.hs b/test/HelloSpec.hs new file mode 100644 --- /dev/null +++ b/test/HelloSpec.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns, MultiParamTypeClasses, FlexibleInstances #-} +{- + Test simple routes +-} +module HelloSpec (spec) where + +import Data.Maybe (fromMaybe) +import Network.Wai (Application) +import Helix +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 +/subsite SubR SubRoute getSubRoute +/nested NestedR: + / NRootR GET + /abcd AbcdR GET +|] + +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 + +-- Nested routes +getNRootR, getAbcdR :: Handler MyRoute +getNRootR = runHandlerM $ plain "Nested ROOT" +getAbcdR = runHandlerM $ plain "Nested ABCD" + +-- 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 helix 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 helix 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 /subsite" $ + it "can access the subsite correctly" $ + get "/subsite" `shouldRespondWith` "subsite-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /nested" $ + it "can access nested routes root correctly" $ + get "/nested" `shouldRespondWith` "Nested ROOT" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /nested/abcd" $ + it "can access nested routes correctly" $ + get "/nested/abcd" `shouldRespondWith` "Nested ABCD" {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/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/test/static/lambda.png b/test/static/lambda.png new file mode 100644 Binary files /dev/null and b/test/static/lambda.png differ