wai-routes 0.9.8 → 0.9.9

raw patch · 33 files changed

+2252/−2199 lines, 33 filesdep ~aesondep ~basedep ~hspecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, base, hspec, hspec-wai, hspec-wai-json

API changes (from Hackage documentation)

Files

• README.md +2/−1
• src/Network/Wai/Middleware/Routes.hs +5/−116
• src/Network/Wai/Middleware/Routes/Class.hs +0/−24
• src/Network/Wai/Middleware/Routes/ContentTypes.hs +0/−95
• src/Network/Wai/Middleware/Routes/DefaultRoute.hs +0/−35
• src/Network/Wai/Middleware/Routes/Handler.hs +0/−599
• src/Network/Wai/Middleware/Routes/Monad.hs +0/−86
• src/Network/Wai/Middleware/Routes/Overlap.hs +0/−88
• src/Network/Wai/Middleware/Routes/Parse.hs +0/−254
• src/Network/Wai/Middleware/Routes/Routes.hs +0/−299
• src/Network/Wai/Middleware/Routes/TH.hs +0/−16
• src/Network/Wai/Middleware/Routes/TH/Dispatch.hs +0/−202
• src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs +0/−44
• src/Network/Wai/Middleware/Routes/TH/RenderRoute.hs +0/−174
• src/Network/Wai/Middleware/Routes/TH/RouteAttrs.hs +0/−38
• src/Network/Wai/Middleware/Routes/TH/Types.hs +0/−101
• src/Routes/Class.hs +24/−0
• src/Routes/ContentTypes.hs +94/−0
• src/Routes/DefaultRoute.hs +35/−0
• src/Routes/Handler.hs +604/−0
• src/Routes/Monad.hs +86/−0
• src/Routes/Overlap.hs +88/−0
• src/Routes/Parse.hs +254/−0
• src/Routes/Routes.hs +309/−0
• src/Routes/TH.hs +16/−0
• src/Routes/TH/Dispatch.hs +202/−0
• src/Routes/TH/ParseRoute.hs +51/−0
• src/Routes/TH/RenderRoute.hs +181/−0
• src/Routes/TH/RouteAttrs.hs +45/−0
• src/Routes/TH/Types.hs +101/−0
• src/Wai/Routes.hs +129/−0
• test/HelloSpec.hs +1/−2
• wai-routes.cabal +25/−25

@@ -1,4 +1,4 @@-[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.8-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes)+[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.9-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) ====================================  Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs.@@ -114,6 +114,7 @@ Changelog ========= +* 0.9.9 : GHC 8 compatibility. Change namespace from Network.Wai.Middleware.Routes -> Wai.Routes * 0.9.8 : Allow Data.Default-0.1.0. Allow comments in route definitions. Some other minor changes. * 0.9.7 : Allow Aeson-0.11. Export Env, RequestData, and show/readRoute to enable "bare" handlers. * 0.9.6 : Subsites now receive parent route arguments, in line with regular nested routes

@@ -8,122 +8,11 @@ Portability :  non-portable (uses ghc extensions)  This package provides typesafe URLs for Wai applications.--}-module Network.Wai.Middleware.Routes-    ( -- * 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-    , showRoute-    , showRouteQuery-    , readRoute-    , 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 wai-routes handler-    , catchall               -- | Catch all routes with the supplied application-    , defaultAction          -- | A synonym for `catchall`, kept for backwards compatibility-    , middleware             -- | Add another middleware to the app-    , 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--    -- * Bare Handlers-    , 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--    , module Network.HTTP.Types.Status-    , module Network.Wai.Middleware.RequestLogger-    , module Network.Wai.Application.Static-  )+* Deprecated*: Use Wai.Routes instead.+-}+module Network.Wai.Middleware.Routes {-# DEPRECATED "Use Wai.Routes instead" #-}+  ( module Wai.Routes )   where -import Network.Wai.Middleware.Routes.Routes-import Network.Wai.Middleware.Routes.Monad-import Network.Wai.Middleware.Routes.Handler-import Network.HTTP.Types.Status-import Network.Wai.Middleware.RequestLogger-import Network.Wai.Application.Static+import Wai.Routes

@@ -1,24 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.Wai.Middleware.Routes.Class-    ( RenderRoute (..)-    , ParseRoute (..)-    , RouteAttrs (..)-    ) where--import Data.Text (Text)-import Data.Set (Set)--class Eq (Route a) => RenderRoute a where-    -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> 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 <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.

@@ -1,95 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}--{- |-Module      :  Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.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"-

@@ -1,35 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--{- |-Module      :  Network.Wai.Middleware.Routes.DefaultRoute-Copyright   :  (c) Anupam Jain 2013 - 2015-License     :  MIT (see the file LICENSE)--Maintainer  :  ajnsit@gmail.com-Stability   :  experimental-Portability :  non-portable (uses ghc extensions)--Defines a DefaultMaster datatype and associated route (DefaultRoute) which is used for "unrouted" handlers--}-module Network.Wai.Middleware.Routes.DefaultRoute-  ( DefaultMaster(..)-  , Route(DefaultRoute)-  )-  where--import Data.Text (Text)-import Data.Set (empty)--import Network.Wai.Middleware.Routes.Routes---- Default master datatype, which is used for "unrouted" handlers-data DefaultMaster = DefaultMaster 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

@@ -1,599 +0,0 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}-{- |-Module      :  Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.Handler-    ( HandlerM()             -- | A Monad that makes it easier to build a Handler-    , runHandlerM            -- | Run a HandlerM to get a Handler-    , mountedAppHandler      -- | Convert a full wai application to a HandlerS-    , request                -- | Access the request data-    , isWebsocket            -- | Is this a websocket request-    , reqHeader              -- | Get a particular request header (case insensitive)-    , 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, responseRaw, responseFile, responseBuilder, responseStream, queryString, StreamingBody, requestHeaders, FilePart)-#if MIN_VERSION_wai(3,0,1)-import Network.Wai (strictRequestBody, vault)-#endif-import Network.Wai.Middleware.Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, showRoute, showRouteQuery, readRoute, readQueryString)-import Network.Wai.Middleware.Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..))-import Network.Wai.Middleware.Routes.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll)--import Control.Monad (liftM, when)-import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, liftIO, MonadTrans)--import Control.Arrow ((***))-import Control.Applicative (Applicative, (<$>), (<*>))--import Data.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)--import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8)--import Data.CaseInsensitive (CI, mk)--import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..))-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 (decodeUtf8 *** decodeUtf8)     params-    files'  = map (decodeUtf8 *** decodeFileInfo) 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 = app . waiReq---- | "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)-  -- Fetch the internal response structure-  let respData = fromMaybe defaultResponse (respResp st)-  -- Handle cookies (add them to headers)-  let headers' = map mkSetCookie (respCookies st) ++ respHeaders st-  -- Construct the actual wai response-  case mkResponse (respStatus st) headers' respData of-    -- Abort handling current response and move to next handler-    Nothing -> runNext (getRequestData st) hh-    -- Normal handling-    Just resp ->-      -- 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 rstatus headers (ResponseFile path part) = Just $ responseFile rstatus headers path part-    mkResponse rstatus headers (ResponseBuilder builder) = Just $ responseBuilder rstatus headers builder-    mkResponse rstatus headers (ResponseStream streaming) = Just $ responseStream rstatus headers streaming-    mkResponse _ _ ResponseNext = Nothing---- | 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 b = modify addHeader-  where-    addHeader :: HandlerState sub master -> HandlerState sub master-    addHeader st@(HandlerState {respHeaders=hs}) = st {respHeaders=(h,b):hs}---- | Set the response status-status :: Status -> HandlerM sub master ()-status s = modify setStatus-  where-    setStatus :: HandlerState sub master -> HandlerState sub master-    setStatus 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 Network.Wai.Middleware.Routes.ContentTypes for examples)---  And sets the body of the response to the given Text-asContent :: ByteString -> Text -> HandlerM sub master ()-asContent ctype s = do-  header contentType ctype-  raw $ encodeUtf8 s---- | Sets the response body when the content type is acceptable-content :: [ByteString] -> Text -> HandlerM sub master ()-content [] _ = return ()-content ctypes s = whenContent ctypes (asContent (head ctypes) s)---- | 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

@@ -1,86 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-}--{- |-Module      :  Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.Routes-import Network.Wai.Middleware.Routes.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 wai-routes 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

@@ -1,88 +0,0 @@--- | Check for overlapping routes.-module Network.Wai.Middleware.Routes.Overlap-    ( findOverlapNames-    , Overlap (..)-    ) where--import Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.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

@@ -1,254 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternGuards #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter-module Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.TH-import Network.Wai.Middleware.Routes.Overlap (findOverlapNames)-import Data.List (foldl', isPrefixOf)-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 (not . isPrefixOf "--") $ 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)

@@ -1,299 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-{- |-Module      :  Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.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 wai-routes-    , runHandler-    , readQueryString-    )-    where---- Wai-import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..))-import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText)---- Network.Wai.Middleware.Routes-import Network.Wai.Middleware.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))-import Network.Wai.Middleware.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)-import Network.Wai.Middleware.Routes.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 =-  mkDispatchClause MkDispatchSettings-    { mdsRunHandler    = [| runHandler    |]-    , mdsSubDispatcher = [| subDispatcher |]-    , mdsGetPathInfo   = [| getPathInfo   |]-    , mdsMethod        = [| getReqMethod  |]-    , mdsSetPathInfo   = [| setPathInfo   |]-    , mds404           = [| app404        |]-    , mds405           = [| app405        |]-    , mdsGetHandler    = defaultGetHandler-    , mdsUnwrapper     = return-    }----- | 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

@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Network.Wai.Middleware.Routes.TH-    ( module Network.Wai.Middleware.Routes.TH.Types-      -- * Functions-    , module Network.Wai.Middleware.Routes.TH.RenderRoute-    , module Network.Wai.Middleware.Routes.TH.ParseRoute-    , module Network.Wai.Middleware.Routes.TH.RouteAttrs-      -- ** Dispatch-    , module Network.Wai.Middleware.Routes.TH.Dispatch-    ) where--import Network.Wai.Middleware.Routes.TH.Types-import Network.Wai.Middleware.Routes.TH.RenderRoute-import Network.Wai.Middleware.Routes.TH.ParseRoute-import Network.Wai.Middleware.Routes.TH.RouteAttrs-import Network.Wai.Middleware.Routes.TH.Dispatch

@@ -1,202 +0,0 @@-{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}-module Network.Wai.Middleware.Routes.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 Network.Wai.Middleware.Routes.TH.Types-import Data.Char (toLower)--data MkDispatchSettings b site c = 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-    , mdsUnwrapper :: Exp -> Q Exp-    }--data SDC = SDC-    { clause404 :: Clause-    , extraParams :: [Exp]-    , extraCons :: [Exp]-    , envExp :: Exp-    , reqExp :: Exp-    }---- | A simpler version of Network.Wai.Middleware.Routes.TH.Dispatch.mkDispatchClause, based on--- view patterns.------ Since 1.4.0-mkDispatchClause :: MkDispatchSettings b site c -> [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-                            handlerE <- mdsUnwrapper $ 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 allDyns = extraParams ++ dyns-                    sroute <- newName "sroute"-                    let sub2 = LamE [VarP sub]-                            (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)-                    let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp-                        route' = foldl' AppE (ConE (mkName name)) dyns-                        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

@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Network.Wai.Middleware.Routes.TH.ParseRoute-    ( -- ** ParseRoute-      mkParseRouteInstance-    ) where--import Network.Wai.Middleware.Routes.TH.Types-import Language.Haskell.TH.Syntax-import Data.Text (Text)-import Network.Wai.Middleware.Routes.Class-import Network.Wai.Middleware.Routes.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|]-            , mdsUnwrapper = return-            }-        (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

@@ -1,174 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-module Network.Wai.Middleware.Routes.TH.RenderRoute-    ( -- ** RenderRoute-      mkRenderRouteInstance-    , mkRenderRouteInstance'-    , mkRouteCons-    , mkRenderRouteClauses-    ) where--import Network.Wai.Middleware.Routes.TH.Types-#if MIN_VERSION_template_haskell(2,11,0)-import Language.Haskell.TH (conT)-#endif-import Language.Haskell.TH.Syntax-import Data.Maybe (maybeToList)-import Control.Monad (replicateM)-import Data.Text (pack)-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))-import Network.Wai.Middleware.Routes.Class-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-import Data.Monoid (mconcat)-#endif---- | Generate the constructors of a route data type.-mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])-mkRouteCons rttypes =-    mconcat <$> mapM mkRouteCon rttypes-  where-    mkRouteCon (ResourceLeaf res) =-        return ([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) = do-        (cons, decs) <- mkRouteCons children-#if MIN_VERSION_template_haskell(2,11,0)-        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]-#else-        let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]-#endif-        return ([con], dec : decs)-      where-        con = NormalC (mkName name)-            $ map (\x -> (notStrict, x))-            $ concat [singles, [ConT $ mkName name]]--        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-    (cons, decs) <- mkRouteCons ress-#if MIN_VERSION_template_haskell(2,11,0)-    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes-#else-    let did = DataInstD [] ''Route [typ] cons clazzes-#endif-    return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)-        [ did-        , FunD (mkName "renderRoute") cls-        ] : decs-  where-    clazzes = [''Show, ''Eq, ''Read]--#if MIN_VERSION_template_haskell(2,11,0)-notStrict :: Bang-notStrict = Bang NoSourceUnpackedness NoSourceStrictness-#else-notStrict :: Strict-notStrict = NotStrict-#endif

@@ -1,38 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}-module Network.Wai.Middleware.Routes.TH.RouteAttrs-    ( mkRouteAttrsInstance-    ) where--import Network.Wai.Middleware.Routes.TH.Types-import Network.Wai.Middleware.Routes.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)

@@ -1,101 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TemplateHaskell #-}--- | Warning! This module is considered internal and may have breaking changes-module Network.Wai.Middleware.Routes.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

@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Routes.Class+    ( RenderRoute (..)+    , ParseRoute (..)+    , RouteAttrs (..)+    ) where++import Data.Text (Text)+import Data.Set (Set)++class Eq (Route a) => RenderRoute a where+    -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> 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 <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.

@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}++{- |+Module      :  Routes.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 Routes.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"

@@ -0,0 +1,35 @@+{-# LANGUAGE TypeFamilies #-}++{- |+Module      :  Routes.DefaultRoute+Copyright   :  (c) Anupam Jain 2013 - 2015+License     :  MIT (see the file LICENSE)++Maintainer  :  ajnsit@gmail.com+Stability   :  experimental+Portability :  non-portable (uses ghc extensions)++Defines a DefaultMaster datatype and associated route (DefaultRoute) which is used for "unrouted" handlers+-}+module Routes.DefaultRoute+  ( DefaultMaster(..)+  , Route(DefaultRoute)+  )+  where++import Data.Text (Text)+import Data.Set (empty)++import Routes.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

@@ -0,0 +1,604 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}+{- |+Module      :  Routes.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 Routes.Handler+    ( HandlerM()             -- | A Monad that makes it easier to build a Handler+    , runHandlerM            -- | Run a HandlerM to get a Handler+    , mountedAppHandler      -- | Convert a full wai application to a HandlerS+    , request                -- | Access the request data+    , isWebsocket            -- | Is this a websocket request+    , reqHeader              -- | Get a particular request header (case insensitive)+    , 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, responseRaw, responseFile, responseBuilder, responseStream, queryString, StreamingBody, requestHeaders, FilePart)+#if MIN_VERSION_wai(3,0,1)+import Network.Wai (strictRequestBody, vault)+#endif+import Routes.Routes (Env(..), RequestData, HandlerS, waiReq, currentRoute, runNext, showRoute, showRouteQuery, readRoute, readQueryString)+import Routes.Class (Route, RenderRoute, ParseRoute, RouteAttrs(..))+import Routes.ContentTypes (acceptContentType, contentType, contentTypeFromFile, typeHtml, typeJson, typePlain, typeCss, typeJavascript, typeAll)++import Control.Monad (liftM, when)+import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, liftIO, MonadTrans)++import Control.Arrow ((***))+import Control.Applicative (Applicative, (<$>), (<*>))++import Data.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+#if MIN_VERSION_aeson(0,10,0)+#else+import qualified Data.Aeson.Encode as AE+#endif++import Data.Set (Set)+import qualified Data.Set as S (empty)++import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)++import Data.CaseInsensitive (CI, mk)++import Web.Cookie (CookiesText, parseCookiesText, renderSetCookie, SetCookie(..))+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 (decodeUtf8 *** decodeUtf8)     params+    files'  = map (decodeUtf8 *** decodeFileInfo) 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 = app . waiReq++-- | "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)+  -- Fetch the internal response structure+  let respData = fromMaybe defaultResponse (respResp st)+  -- Handle cookies (add them to headers)+  let headers' = map mkSetCookie (respCookies st) ++ respHeaders st+  -- Construct the actual wai response+  case mkResponse (respStatus st) headers' respData of+    -- Abort handling current response and move to next handler+    Nothing -> runNext (getRequestData st) hh+    -- Normal handling+    Just resp ->+      -- 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 rstatus headers (ResponseFile path part) = Just $ responseFile rstatus headers path part+    mkResponse rstatus headers (ResponseBuilder builder) = Just $ responseBuilder rstatus headers builder+    mkResponse rstatus headers (ResponseStream streaming) = Just $ responseStream rstatus headers streaming+    mkResponse _ _ ResponseNext = Nothing++-- | 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 b = modify addHeader+  where+    addHeader :: HandlerState sub master -> HandlerState sub master+    addHeader st@(HandlerState {respHeaders=hs}) = st {respHeaders=(h,b):hs}++-- | Set the response status+status :: Status -> HandlerM sub master ()+status s = modify setStatus+  where+    setStatus :: HandlerState sub master -> HandlerState sub master+    setStatus 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,10,0)+    _encode = A.fromEncoding . A.toEncoding+#elif 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 Routes.ContentTypes for examples)+--  And sets the body of the response to the given Text+asContent :: ByteString -> Text -> HandlerM sub master ()+asContent ctype s = do+  header contentType ctype+  raw $ encodeUtf8 s++-- | Sets the response body when the content type is acceptable+content :: [ByteString] -> Text -> HandlerM sub master ()+content [] _ = return ()+content ctypes s = whenContent ctypes (asContent (head ctypes) s)++-- | 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

@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes, DeriveFunctor #-}++{- |+Module      :  Routes.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 Routes.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 Routes.Routes+import Routes.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 wai-routes 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

@@ -0,0 +1,88 @@+-- | Check for overlapping routes.+module Routes.Overlap+    ( findOverlapNames+    , Overlap (..)+    ) where++import Routes.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 Routes.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

@@ -0,0 +1,254 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module Routes.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 Routes.TH+import Routes.Overlap (findOverlapNames)+import Data.List (foldl', isPrefixOf)+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 (not . isPrefixOf "--") $ 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)

@@ -0,0 +1,309 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{- |+Module      :  Routes.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 Routes.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 wai-routes+    , runHandler+    , readQueryString+    )+    where++-- Wai+import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..))+import Network.HTTP.Types (Query, decodePath, encodePath, queryTextToQuery, queryToQueryText)++-- Routes+import Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))+import Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)+import Routes.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+#if MIN_VERSION_template_haskell(2,11,0)+  let inst = InstanceD Nothing+#else+  let inst = InstanceD+#endif+  return [inst []+          (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+#if MIN_VERSION_template_haskell(2,11,0)+  let inst = InstanceD Nothing+#else+  let inst = InstanceD+#endif+  return [inst [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 =+  mkDispatchClause MkDispatchSettings+    { mdsRunHandler    = [| runHandler    |]+    , mdsSubDispatcher = [| subDispatcher |]+    , mdsGetPathInfo   = [| getPathInfo   |]+    , mdsMethod        = [| getReqMethod  |]+    , mdsSetPathInfo   = [| setPathInfo   |]+    , mds404           = [| app404        |]+    , mds405           = [| app405        |]+    , mdsGetHandler    = defaultGetHandler+    , mdsUnwrapper     = return+    }+++-- | 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

@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Routes.TH+    ( module Routes.TH.Types+      -- * Functions+    , module Routes.TH.RenderRoute+    , module Routes.TH.ParseRoute+    , module Routes.TH.RouteAttrs+      -- ** Dispatch+    , module Routes.TH.Dispatch+    ) where++import Routes.TH.Types+import Routes.TH.RenderRoute+import Routes.TH.ParseRoute+import Routes.TH.RouteAttrs+import Routes.TH.Dispatch

@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}+module Routes.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 Routes.TH.Types+import Data.Char (toLower)++data MkDispatchSettings b site c = 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+    , mdsUnwrapper :: Exp -> Q Exp+    }++data SDC = SDC+    { clause404 :: Clause+    , extraParams :: [Exp]+    , extraCons :: [Exp]+    , envExp :: Exp+    , reqExp :: Exp+    }++-- | A simpler version of Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- Since 1.4.0+mkDispatchClause :: MkDispatchSettings b site c -> [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+                            handlerE <- mdsUnwrapper $ 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 allDyns = extraParams ++ dyns+                    sroute <- newName "sroute"+                    let sub2 = LamE [VarP sub]+                            (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)+                    let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp+                        route' = foldl' AppE (ConE (mkName name)) dyns+                        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

@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Routes.TH.ParseRoute+    ( -- ** ParseRoute+      mkParseRouteInstance+    ) where++import Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import Routes.Class+import Routes.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|]+            , mdsUnwrapper = return+            }+        (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++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif

@@ -0,0 +1,181 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Routes.TH.RenderRoute+    ( -- ** RenderRoute+      mkRenderRouteInstance+    , mkRenderRouteInstance'+    , mkRouteCons+    , mkRenderRouteClauses+    ) where++import Routes.TH.Types+#if MIN_VERSION_template_haskell(2,11,0)+import Language.Haskell.TH (conT)+#endif+import Language.Haskell.TH.Syntax+import Data.Maybe (maybeToList)+import Control.Monad (replicateM)+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Routes.Class+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Monoid (mconcat)+#endif++-- | Generate the constructors of a route data type.+mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteCons rttypes =+    mconcat <$> mapM mkRouteCon rttypes+  where+    mkRouteCon (ResourceLeaf res) =+        return ([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) = do+        (cons, decs) <- mkRouteCons children+#if MIN_VERSION_template_haskell(2,11,0)+        dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]+#else+        let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]+#endif+        return ([con], dec : decs)+      where+        con = NormalC (mkName name)+            $ map (\x -> (notStrict, x))+            $ concat [singles, [ConT $ mkName name]]++        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+    (cons, decs) <- mkRouteCons ress+#if MIN_VERSION_template_haskell(2,11,0)+    did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes+#else+    let did = DataInstD [] ''Route [typ] cons clazzes+#endif+    return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)+        [ did+        , FunD (mkName "renderRoute") cls+        ] : decs+  where+    clazzes = [''Show, ''Eq, ''Read]++#if MIN_VERSION_template_haskell(2,11,0)+notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness+#else+notStrict :: Strict+notStrict = NotStrict+#endif++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif

@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE RecordWildCards #-}+module Routes.TH.RouteAttrs+    ( mkRouteAttrsInstance+    ) where++import Routes.TH.Types+import Routes.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)++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif

@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Warning! This module is considered internal and may have breaking changes+module Routes.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

@@ -0,0 +1,129 @@+{- |+Module      :  Wai.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 Wai.Routes+    ( -- * 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+    , showRoute+    , showRouteQuery+    , readRoute+    , 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 wai-routes handler+    , catchall               -- | Catch all routes with the supplied application+    , defaultAction          -- | A synonym for `catchall`, kept for backwards compatibility+    , middleware             -- | Add another middleware to the app+    , 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++    -- * Bare Handlers+    , 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++    , module Network.HTTP.Types.Status+    , module Network.Wai.Middleware.RequestLogger+    , module Network.Wai.Application.Static+  )+  where++import Routes.Routes+import Routes.Monad+import Routes.Handler+import Network.HTTP.Types.Status+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Application.Static

@@ -6,7 +6,7 @@  import Data.Maybe (fromMaybe) import Network.Wai (Application)-import Network.Wai.Middleware.Routes+import Wai.Routes import Data.Aeson (Value(Number), (.=), object)  import Data.Text (Text)@@ -142,4 +142,3 @@   describe "GET /lambda.png" $     it "returns a file correctly" $       get "/lambda.png" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "image/png"]}-

@@ -1,5 +1,5 @@ name               : wai-routes-version            : 0.9.8+version            : 0.9.9 cabal-version      : >=1.18 build-type         : Simple license            : MIT@@ -21,18 +21,18 @@  source-repository this     type     : git-    location : http://github.com/ajnsit/wai-routes/tree/v0.9.8-    tag      : v0.9.8+    location : http://github.com/ajnsit/wai-routes/tree/v0.9.9+    tag      : v0.9.9  library-    build-depends      : base               >= 4.7  && < 4.9+    build-depends      : base               >= 4.7  && < 4.10                        , 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.12+                       , aeson              >= 0.8  && < 1.1                        , containers         >= 0.5  && < 0.6                        , random             >= 1.1  && < 1.2                        , path-pieces        >= 0.2  && < 0.3@@ -46,21 +46,21 @@                        , cookie             >= 0.4  && < 0.5                        , data-default-class >= 0.0  && < 0.2                        , vault              >= 0.3  && < 0.4-    exposed-modules    : Network.Wai.Middleware.Routes-    other-modules      : Network.Wai.Middleware.Routes.Parse-                         Network.Wai.Middleware.Routes.Overlap-                         Network.Wai.Middleware.Routes.Class-                         Network.Wai.Middleware.Routes.Routes-                         Network.Wai.Middleware.Routes.Monad-                         Network.Wai.Middleware.Routes.Handler-                         Network.Wai.Middleware.Routes.ContentTypes-                         Network.Wai.Middleware.Routes.DefaultRoute-                         Network.Wai.Middleware.Routes.TH-                         Network.Wai.Middleware.Routes.TH.Types-                         Network.Wai.Middleware.Routes.TH.Dispatch-                         Network.Wai.Middleware.Routes.TH.ParseRoute-                         Network.Wai.Middleware.Routes.TH.RenderRoute-                         Network.Wai.Middleware.Routes.TH.RouteAttrs+    exposed-modules    : Wai.Routes, Network.Wai.Middleware.Routes+    other-modules      : Routes.Parse+                         Routes.Overlap+                         Routes.Class+                         Routes.Routes+                         Routes.Monad+                         Routes.Handler+                         Routes.ContentTypes+                         Routes.DefaultRoute+                         Routes.TH+                         Routes.TH.Types+                         Routes.TH.Dispatch+                         Routes.TH.ParseRoute+                         Routes.TH.RenderRoute+                         Routes.TH.RouteAttrs                          Util.Free     exposed            : True     buildable          : True@@ -76,12 +76,12 @@   hs-source-dirs   : test   GHC-options      : -Wall -threaded -fno-warn-orphans -  build-depends    : base           >= 4.7 && < 4.9+  build-depends    : base           >= 4.7 && < 4.10                    , wai            >= 3.0 && < 3.3-                   , aeson          >= 0.8 && < 0.12-                   , hspec          >= 2.1 && < 2.3-                   , hspec-wai      >= 0.6 && < 0.7-                   , hspec-wai-json >= 0.6 && < 0.7+                   , aeson          >= 0.8 && < 1.1+                   , hspec          >= 2.1 && < 2.4+                   , hspec-wai      >= 0.6 && < 0.9+                   , hspec-wai-json >= 0.6 && < 0.9                    , text           >= 1.2 && < 1.3                    , wai-routes   ghc-options        : -Wall