diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 1.0.0 + +Major rewrite. Please refer to the package documentation for details. + ## 0.4.0 * GHC 8.4 compatibility. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,6 @@ wai-route [![Build Status](https://travis-ci.org/romanb/wai-route.svg)](https://travis-ci.org/romanb/wai-route) -======== +========= -Minimalistic, efficient routing tree for applications using the [WAI](https://github.com/yesodweb/wai). Take a look at the [sample](https://github.com/romanb/wai-route/blob/master/sample/Main.hs). +[WAI](https://github.com/yesodweb/wai) middleware for path-based request routing +with captures. + diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,3 @@ +import Test.DocTest + +main = doctest ["src", "examples"] diff --git a/examples/basic.hs b/examples/basic.hs new file mode 100644 --- /dev/null +++ b/examples/basic.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE + TypeApplications + , DataKinds + , GADTs + , OverloadedStrings + , LambdaCase +#-} + +module Examples.Basic where + +import Data.Binary.Builder (toLazyByteString) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Network.Wai.Route +import Prelude + +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as LC8 +import qualified Data.Text as Text + +-- $setup +-- >>> :set -XOverloadedStrings + +-- Routes + +routes :: [Route IO] +routes = + [ defRoute (str "add" ./ var @"x" ./ var @"y" ./ end) + addHandler + + , defRoute (str "echo" ./ some @Text ./ end) + echoHandler + + , defRoute (str "reverse" ./ some @Text ./ end) $ + \(t ::: Nil) _rq send -> + let t' = Text.reverse t + in send (response200 (encodeUtf8 (fromStrict t'))) + + , defRoute (str "upper" ./ some @Text ./ end) $ + \(t ::: Nil) -> byMethod $ \case + GET -> \_rq send -> + let t' = Text.toUpper t + in send (response200 (encodeUtf8 (fromStrict t'))) + _ -> app405 + ] + +addHandler :: Params '[Var "x" Int, Var "y" Int] -> App IO +addHandler (x ::: y ::: Nil) _rq send = + send (response200 (LC8.pack (show (x + y)))) + +echoHandler :: Params '[Some Text] -> App IO +echoHandler (t ::: Nil) = + withQuery (qdef @"repeat" @Int 1) appQueryError $ + \(rep ::: Nil) _rq send -> + let t' = Text.replicate rep t + in send (response200 (encodeUtf8 (fromStrict t'))) + +response200 :: LC8.ByteString -> Response +response200 = responseLBS status200 [] + +-- Fake requests + +addReq :: Request +addReq = defaultRequest { pathInfo = ["add","1","2"] } + +echoReq :: Request +echoReq = defaultRequest { pathInfo = ["echo","Hello"] } + +reverseReq :: Request +reverseReq = defaultRequest { pathInfo = ["reverse","Hello"] } + +upperReq :: Request +upperReq = defaultRequest { pathInfo = ["upper","Hello"] } + +-- Fake response sending + +printResponse :: Response -> IO ResponseReceived +printResponse rs = do + case rs of + ResponseBuilder s _ b -> do + putStr (show (statusCode s)) + putStr " " + putStr (C8.unpack (statusMessage s)) + putStr ": " + putStrLn (LC8.unpack (toLazyByteString b)) + _ -> return () + return ResponseReceived + +-- Application + +app :: App IO +app = route (compileRoutes routes) app404 + +-- $examples +-- +-- >>> app addReq printResponse +-- 200 OK: 3 +-- +-- >>> app echoReq printResponse +-- 200 OK: Hello +-- +-- >>> app echoReq { queryString = [("repeat", Just "2")] } printResponse +-- 200 OK: HelloHello +-- +-- >>> app echoReq { queryString = [("repeat", Just "a")] } printResponse +-- 400 Bad Request: Invalid parameter [repeat=a]... +-- +-- >>> app reverseReq printResponse +-- 200 OK: olleH +-- +-- >>> app upperReq printResponse +-- 200 OK: HELLO +-- +-- >>> app upperReq { requestMethod = "POST" } printResponse +-- 405 Method Not Allowed: + diff --git a/examples/compose.hs b/examples/compose.hs new file mode 100644 --- /dev/null +++ b/examples/compose.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE + TypeApplications + , DataKinds + , GADTs + , OverloadedStrings +#-} + +module Examples.Wildcard where + +import Data.Binary.Builder (toLazyByteString) +import Data.Text (Text) +import Data.Text.Lazy (fromStrict) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Network.Wai.Route +import Prelude + +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy.Char8 as LC8 +import qualified Data.Text as Text + +-- $setup +-- >>> :set -XOverloadedStrings + +-- Routes + +prefixRoutes :: [Route IO] +prefixRoutes = [ defRoute (str "files" ./ end) filesHandler ] + +otherRoutes :: [Route IO] +otherRoutes = [ defRoute (str "echo" ./ some @Text ./ end) echoHandler ] + +filesHandler :: Params '[] -> App IO +filesHandler Nil rq send = + let path = Text.intercalate "/" (pathInfo rq) + in send (response200 (encodeUtf8 (fromStrict path))) + +echoHandler :: Params '[Some Text] -> App IO +echoHandler (t ::: Nil) _rq send = + send (response200 (encodeUtf8 (fromStrict t))) + +response200 :: LC8.ByteString -> Response +response200 = responseLBS status200 [] + +-- Fake requests + +filesReq :: Request +filesReq = defaultRequest { pathInfo = ["files","foo","bar","baz.jpg"] } + +echoReq :: Request +echoReq = defaultRequest { pathInfo = ["echo","Hello"] } + +bogusReq :: Request +bogusReq = defaultRequest { pathInfo = ["bogus"] } + +-- Fake response sending + +printResponse :: Response -> IO ResponseReceived +printResponse rs = do + case rs of + ResponseBuilder s _ b -> do + putStr (show (statusCode s)) + putStr " " + putStr (C8.unpack (statusMessage s)) + putStr ": " + putStrLn (LC8.unpack (toLazyByteString b)) + _ -> return () + return ResponseReceived + +-- Application + +app :: App IO +app = routePrefix (compileRoutes prefixRoutes) + $ route (compileRoutes otherRoutes) + $ app404 + +-- $examples +-- +-- >>> app filesReq printResponse +-- 200 OK: foo/bar/baz.jpg +-- +-- >>> app echoReq printResponse +-- 200 OK: Hello +-- +-- >>> app bogusReq printResponse +-- 404 Not Found: + diff --git a/sample/Main.hs b/sample/Main.hs deleted file mode 100644 --- a/sample/Main.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Route (route) - -import qualified Data.ByteString.Lazy as L - -main :: IO () -main = run 4242 $ - route [ ("/foo", fooHandler) - , ("/foo/bar", barHandler) - , ("/foo/:bar/:baz", bazHandler) - ] - where - fooHandler _ _ k = k $ responseLBS status200 [] "foo!" - barHandler _ _ k = k $ responseLBS status200 [] "bar!" - bazHandler p rq k = do - print $ "pathInfo: " ++ show (pathInfo rq) - print $ "captured: " ++ show p - k $ responseLBS status200 [] - $ maybe L.empty L.fromStrict (lookup "baz" p) diff --git a/src/Network/Wai/Route.hs b/src/Network/Wai/Route.hs --- a/src/Network/Wai/Route.hs +++ b/src/Network/Wai/Route.hs @@ -2,37 +2,677 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE + BangPatterns + , DataKinds + , FlexibleContexts + , GADTs + , MagicHash + , OverloadedStrings + , ScopedTypeVariables + , StandaloneDeriving + , StrictData + , TypeApplications + , TypeFamilies + , TypeInType + , TypeOperators + , UndecidableInstances +#-} +-- | This module provides a WAI 'Middleware' for routing requests +-- to handlers (i.e. 'Application's) based on the request path, +-- thereby optionally capturing variables. +-- +-- The basic functionality is provided by 'route' and 'routePrefix'. +-- The 'RoutingTrie's for the middleware can be constructed directly +-- or by compiling 'Route's via the construction of 'Path's, +-- which offers enhanced type-safety. +-- +-- Handlers may furthermore parse parameters from query strings, +-- via the construction of 'Query's. Some additional functions +-- for working with HTTP methods and request headers are also +-- provided. +-- +-- The sources contain some +-- . +-- +-- __Strictness__: This module uses @-XStrictData@. module Network.Wai.Route - ( Handler + ( -- | The following extensions are used for all inline examples. + -- $setup + + -- | More extensive examples can be found in the @examples@ + -- directory of the source distribution. + + -- * Middleware + App + , Handler + , RoutingTrie , route + , routePrefix + + -- * Routes + , Route (..) + , defRoute + , compileRoute + , compileRoutes + + -- * Parameters + , Params (..) + , ParamName + , InvalidParam (..) + + -- * Paths + , Path, Vars, Var, Some + , (=~=) + , str, var, some, (./), end + , pathVarsLen + , pathPattern + , parsePath + , PathError (..) + , SomePath (..) + + -- * Query Strings + , Query + , qreq + , qdef + , qopt + , (.&.) + , withQuery + , parseQuery + , QueryError (..) + + -- * Utilities + , VarsLen + , knownVarsLen + + -- ** HTTP Methods + , getMethod + , byMethod + , withMethod + + -- ** HTTP Query Parameters + , getQueryParam + , getQueryParam' + + -- ** HTTP Headers + , getHeader + , InvalidHeader (..) + + -- ** Standard Applications + , appInvalidParam + , appMissingParam + , appQueryError + , app400 + , app404 + , app405 + + -- * Re-exports + , Trie + , Pattern + , Matcher (..) + , Capture (..) + , FromHttpApiData ) where +import GHC.Exts (Proxy#, proxy#) +import GHC.TypeLits + import Data.ByteString (ByteString) -import Network.HTTP.Types +import Data.Kind +import Data.Sequence (Seq (..), (<|)) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Lazy.Builder (fromString, fromText, toLazyText) +import Data.Trie.Pattern +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import Network.HTTP.Types (QueryItem) import Network.Wai -import Network.Wai.Route.Tree -import Prelude hiding (lookup) +import Prelude +import Web.HttpApiData (FromHttpApiData (..)) -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Encoding as LazyText +import qualified Data.Trie.Pattern as Trie --- | A 'Handler' is a generalized 'Application' that receives the captured --- path parameters as its first argument. -type Handler m = [(ByteString, ByteString)] -- ^ The captured path parameters. - -> Request -- ^ The matched 'Request'. - -> (Response -> m ResponseReceived) -- ^ The continuation. - -> m ResponseReceived +-- $setup +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications --- | Routes requests to 'Handler's according to a routing table. -route :: Monad m - => [(ByteString, Handler m)] - -> Request - -> (Response -> m ResponseReceived) - -> m ResponseReceived -route rs rq k = case lookup (fromList rs) segs of - Just e -> value e (captured $ captures e) rq k - Nothing -> k notFound +-- | An 'App' is a WAI 'Application' generalised to any type +-- of kind @* -> *@, and thus in particular any monad, i.e. +-- @App IO ~ Application@. +type App m + = Request + -> (Response -> m ResponseReceived) + -> m ResponseReceived + +-- | A handler function for a routed request. +type Handler m + = Seq (Capture Text) + -> App m + +-- | A routing trie for request paths. +type RoutingTrie m = Trie Text (Handler m) + +-- | Routes requests to 'Handler's via a routing trie, passing +-- along captured path parameters. The request path must fully match a route in +-- order for the associated handler function to be called. If no route matches +-- the request path, the request is forwarded to the 'App'lication given as +-- second argument. +route :: Monad m => RoutingTrie m -> App m -> App m +route rt app rq k = case Trie.match (pathInfo rq) rt of + Just (h, cs) -> h cs rq k + Nothing -> app rq k + +-- | Routes requests to 'Handler's via a routing trie, passing along +-- captured path parameters. A prefix of the request path must match a route in +-- order for the associated handler function to be called. Thereby the route +-- for the longest matching prefix is chosen. If no route matches a +-- prefix of the request path, the request is forward to the 'App'lication +-- given as second argument. +-- +-- /Note/: With prefix routing, the 'pathInfo' of the 'Request' passed to +-- a handler contains only the (unmatched) suffix of the request path, enabling +-- nested / chained routing with multiple routing tries. An example for +-- the composition of routing tries can be seen +-- . +routePrefix :: Monad m => RoutingTrie m -> App m -> App m +routePrefix rt app rq k = case Trie.matchPrefix (pathInfo rq) rt of + Just (h, cs, str') -> h cs (rq { pathInfo = str' }) k + Nothing -> app rq k + +------------------------------------------------------------------------------ +-- Routes + +-- | A route whose handler is run if the path is a match for a request path. +-- The handler function is thereby given the captured and parsed 'Params'. +data Route m = forall vars. Route + { routePath :: Path vars + -- ^ The path that uniquely identifies a route. + , routeHandler :: Params vars -> App m + -- ^ Handler for requests matching the route path. + , routeInvalidParam :: InvalidParam -> App m + -- ^ Callback for invalid path parameters. + } + +-- | Two routes are equal if they have the same path. +instance Eq (Route m) where + (Route p1 _ _) == (Route p2 _ _) = p1 =~= p2 + +-- | Shows the path of the route. +instance Show (Route m) where + show (Route p _ _) = show p + +-- | Define a 'Route' with the given path and handler, using default +-- values for other arguments. +defRoute :: Monad m => Path vars -> (Params vars -> App m) -> Route m +defRoute p h = Route p h appInvalidParam + +-- | Compile a list of 'Route's into a 'RoutingTrie'. +compileRoutes :: Monad m => [Route m] -> RoutingTrie m +compileRoutes = Trie.fromAssocList . map compileRoute + +-- | Compile a 'Route' into a pair of a 'Pattern' and a 'Handler', +-- suitable for insertion into a 'RoutingTrie'. +compileRoute :: Monad m => Route m -> (Pattern Text, Handler m) +compileRoute (Route p h f) = (pathPattern p, handler) where - segs = segments (rawPathInfo rq) - notFound = responseLBS status404 [] L.empty + handler cs = case parsePath p cs of + Right args -> h args + Left (PathInvalidParam x) -> f x + Left PathMissingParams -> + -- Note [Missing path params] + error "wai-route: incomplete parse: missing captures" + +{- Note [Missing path params] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is a central property of the underlying pattern trie that if @p@ is a pattern +in a trie, then a successful match on that pattern yields exactly @n@ captured +values, where @n@ is the number of captures in the pattern. Since the number of +captures in a pattern is equal to the number of variables in a path by +definition of 'Path' and 'pathPattern', an incomplete parse at this point cannot +happen, given the trie works correctly. +-} + +------------------------------------------------------------------------------ +-- Paths + +-- | The names and types of the variables captured in a 'Path'. +type Vars = [(Symbol,Type)] + +-- | A parameter of type @a@ with (type-level) name @s@. +type Var s a = '(s,a) + +-- | An unnamed parameter of type @a@. +type Some a = Var "" a + +-- | A path of a 'Route', indexed by the names and types of +-- the captured variables. +-- +-- Paths are constructed using 'str', 'var', 'some', glued +-- together by './' and terminated by 'end', e.g. +-- +-- >>> let p = str "a" ./ var @"b" @Int ./ str "c" ./ some @Text ./ end +-- >>> :t p +-- p :: Path '[Var "b" Int, Some Text] +-- +-- Two different paths are /overlapping/ iff their underlying 'Pattern's, +-- as given by 'pathPattern', are overlapping. The preference given to +-- routes based on overlapping paths is given by the preference between +-- the overlapping patterns (see the documentation for 'Pattern's). +data Path :: Vars -> Type where + Val :: Text + -> Path vars + -> Path vars + Var :: (KnownSymbol s, Eq a, FromHttpApiData a) + => Proxy# s + -> Proxy# a + -> Path vars + -> Path (Var s a ': vars) + End :: Path '[] + +-- | Equality for paths indexed by the same 'Vars' is subsumed by the +-- structural equality '=~='. +instance Eq (Path vars) where + p1 == p2 = p1 =~= p2 + +-- | Shows paths with a leading "/", whereby 'str'ings stand in +-- for themselves, unnamed 'var'iables are represented by a "*" +-- and named variables are represented by a ":" followed by the +-- name of the variable. +-- +-- >>> let p = str "a" ./ var @"b" @Int ./ str "c" ./ some @Text ./ end +-- >>> p +-- /a/:b/c/* +instance Show (Path vars) where + show End = "" + show (Val s p) = showString "/" . showString (Text.unpack s) . shows p $ "" + show (Var s _ p) = showString "/" . ( + let s' = symbolVal' s + in if null s' + then showString "*" + else showString ":" . showString s' + ) . shows p $ "" + +-- | Structural equality of paths. +-- +-- @p =~= p@ \(\iff\) @'pathPattern' p == pathPattern p@ +-- +(=~=) :: Path vars -> Path vars' -> Bool +(=~=) End End = True +(=~=) (Val s p) (Val s' p') = s == s' && p =~= p' +(=~=) (Var _ _ p) (Var _ _ p') = p =~= p' +(=~=) _ _ = False + +-- | Capture a parameter as a named variable, e.g. +-- +-- >>> let p = var @"name" @Text ./ end +-- >>> :t p +-- p :: Path '[Var "name" Text] +-- +-- The type-level variable name can serve at least two purposes: +-- +-- * It allows to disambiguate multiple parameters of the same type in the +-- path for extra type safety (i.e. against mixing up the order of +-- parameters). +-- * The name is made available at runtime when parsing of a parameter +-- fails in the form of an 'InvalidParam' error, enabling its use in +-- error responses, logs, etc. +-- +var :: (KnownSymbol s, Eq a, FromHttpApiData a) + => Path vars + -> Path (Var s a ': vars) +var = Var proxy# proxy# + +-- | Capture a parameter as an unnamed variable, e.g. +-- +-- >>> let p = some @Text ./ end +-- >>> :t p +-- p :: Path '[Some Text] +some :: (Eq a, FromHttpApiData a) + => Path vars + -> Path (Some a ': vars) +some = var @"" + +-- | Match a fixed string, capturing nothing, e.g. +-- +-- >>> let p = str "tmp" ./ end +-- >>> :t p +-- p :: Path '[] +str :: Text -> Path vars -> Path vars +str = Val + +-- | Right-associative infix operator for constructing 'Path's: +-- +-- >>> let p = str "a" ./ some @Int ./ var @"y" @Int ./ end +-- >>> :t p +-- p :: Path '[Some Int, Var "y" Int] +-- +(./) :: (Path vars -> Path vars') -> Path vars -> Path vars' +(./) f p = f p +infixr 5 ./ + +-- | Mark the end of a path. +end :: Path '[] +end = End + +-- | The underlying structural 'Pattern' of a 'Path'. +pathPattern :: Path vars -> Pattern Text +pathPattern = go Seq.empty + where + go :: Pattern Text -> Path vars -> Pattern Text + go pat (Val s p) = EqStr s <| go pat p + go pat (Var _ _ p) = AnyStr <| go pat p + go pat End = pat + +-- | Compute the length of the list of variables in a 'Path', at runtime. +-- +-- \(\mathcal{O}(n)\), where @n@ is the total length of the path. +-- +-- >>> let p = str "a" ./ some @Text ./ end +-- >>> pathVarsLen p +-- 1 +-- +-- See also 'knownVarsLen' for lengths known at compile-time. +pathVarsLen :: Path vars -> Int +pathVarsLen = go 0 + where + go :: Int -> Path vars -> Int + go !n End = n + go !n (Var _ _ p) = go (n + 1) p + go !n (Val _ p) = go n p + +-- | An error during parsing of the parameters of a 'Path'. +data PathError + = PathMissingParams + -- ^ The path contains more variables than the number of captures given. + | PathInvalidParam InvalidParam + -- ^ A parameter failed to parse into the type expected by the + -- corresponding variable of the path. + deriving (Eq, Show, Read) + +-- | Parse a sequence of captures into a heterogeneous list of 'Params' +-- according to the 'Vars' in the given 'Path'. The number of captures +-- given must be at least as large as the number of variables in the path, +-- in order for the parse to succeed. +parsePath :: Path vars -> Seq (Capture Text) -> Either PathError (Params vars) +parsePath End _ = Right Nil +parsePath (Val _ p) cs = parsePath p cs +parsePath _ Empty = Left PathMissingParams +parsePath (Var s (_ :: Proxy# a) p) (Capture c :<| cs) = + case parseUrlPiece @a c of + Right a -> (a :::) <$> parsePath p cs + Left e -> Left $! PathInvalidParam (InvalidParam (symbolVal' s) c e) + +------------------------------------------------------------------------------ +-- SomePath + +-- | A path with existentially quantified variables. +data SomePath = forall vars. SomePath (Path vars) + +deriving instance Show SomePath + +instance Eq SomePath where + (SomePath p1) == (SomePath p2) = p1 =~= p2 + +------------------------------------------------------------------------------ +-- Query + +-- | A query string with heterogeneously typed variables. +data Query :: Vars -> Type where + QDef :: (Eq a, KnownSymbol s, FromHttpApiData a) + => Proxy# s + -> Proxy# a + -> a + -> Query '[Var s a] + QOpt :: (Eq a, KnownSymbol s, FromHttpApiData a) + => Proxy# s + -> Proxy# a + -> Query '[Var s (Maybe a)] + QReq :: (Eq a, KnownSymbol s, FromHttpApiData a) + => Proxy# s + -> Proxy# a + -> Query '[Var s a] + QAnd :: (Eq a, KnownSymbol s, FromHttpApiData a) + => Query '[Var s a] + -> Query (Var s' a' ': vars) + -> Query (Var s a ': Var s' a' ': vars) + +-- | A required query parameter. +qreq :: (KnownSymbol s, FromHttpApiData a, Eq a) => Query '[Var s a] +qreq = QReq proxy# proxy# + +-- | A query parameter with a default value. The default only applies +-- when the parameter is absent or has no value, not if there is a +-- value that fails to parse. +qdef :: (KnownSymbol s, FromHttpApiData a, Eq a) => a -> Query '[Var s a] +qdef = QDef proxy# proxy# + +-- | An optional query parameter. The parameter value is 'Nothing' only if +-- the parameter is absent or has no value, not if there is a value +-- that fails to parse. +qopt :: (KnownSymbol s, FromHttpApiData a, Eq a) => Query '[Var s (Maybe a)] +qopt = QOpt proxy# proxy# + +-- | Combine a query parameter with one or more other query parameters. +(.&.) :: (Eq a, KnownSymbol s, FromHttpApiData a) + => Query '[Var s a] + -> Query (Var s' a' ': vars) + -> Query (Var s a ': Var s' a' ': vars) +(.&.) = QAnd +infixr 5 .&. + +instance Show (Query vars) where + showsPrec _ (QReq s _ ) = showString (symbolVal' s) . showString "=?[req]" + showsPrec _ (QDef s _ _) = showString (symbolVal' s) . showString "=?[def]" + showsPrec _ (QOpt s _ ) = showString (symbolVal' s) . showString "=?[opt]" + showsPrec _ (QAnd q qs) = shows q . showString "&" . shows qs + +-- | An error during parsing of the parameters for a 'Query'. +data QueryError + = QueryMissingParam ParamName + -- ^ A query parameter is missing. + | QueryInvalidParam InvalidParam + -- ^ A query parameter failed to parse correctly. + deriving (Eq, Show, Read) + +-- | Parse the variables of a 'Query' for the given list of values +-- into 'Params'. +parseQuery :: Query vars -> [QueryItem] -> Either QueryError (Params vars) +parseQuery qry items = case qry of + q@QReq{} -> (::: Nil) <$> parseQ q + q@QDef{} -> (::: Nil) <$> parseQ q + q@QOpt{} -> (::: Nil) <$> parseQ q + QAnd q qs -> (:::) <$> parseQ q <*> parseQuery qs items + where + parseQ :: Query '[Var s a] -> Either QueryError a + parseQ q = case q of + QReq s (_ :: Proxy# a) -> + parse s (parseQParam @a) (Left . QueryMissingParam) + QDef s (_ :: Proxy# a) def -> + parse s (parseQParam @a) (const (Right def)) + QOpt s (_ :: Proxy# a) -> + parse s (\n -> fmap Just . parseQParam @a n) (const (Right Nothing)) + + parse :: KnownSymbol s + => Proxy# s + -> (ParamName -> ByteString -> Either InvalidParam a) + -> (ParamName -> Either QueryError a) + -> Either QueryError a + parse s f g = let name = symbolVal' s in + case Prelude.lookup (C8.pack name) items of + Just (Just val) -> case f name val of + Left e -> Left $! QueryInvalidParam e + Right a -> Right a + _ -> g name + +-- | Run an 'App' after parsing the parameters for the given 'Query' +-- from the request. +withQuery + :: Query vars + -- ^ The query to parse. + -> (QueryError -> App m) + -- ^ The application to run when the query failed to parse. + -> (Params vars -> App m) + -- ^ The application to run with the parsed query parameters. + -> App m +withQuery q onE onP rq = case parseQuery q (queryString rq) of + Left e -> onE e rq + Right p -> onP p rq + +parseQParam :: forall a. FromHttpApiData a + => ParamName + -> ByteString + -> Either InvalidParam a +parseQParam name val = + let val' = decodeUtf8With lenientDecode val + in case parseQueryParam @a val' of + Right a -> Right a + Left e -> Left $! InvalidParam name val' e + +------------------------------------------------------------------------------ +-- Parameters + +type ParamName = String + +-- | A heterogenous list of parameters. +data Params :: Vars -> Type where + Nil :: Params '[] + (:::) :: Eq a => a -> Params vars -> Params (Var s a ': vars) + +infixr 5 ::: +deriving instance Eq (Params vars) + +-- | A parameter could not be parsed correctly. +data InvalidParam = InvalidParam + { invalidParamName :: ParamName + , invalidParamValue :: Text + , invalidParamMsg :: Text + } deriving (Eq, Show, Read) + +------------------------------------------------------------------------------ +-- Utilities + +-- | Compute the length of 'Vars'. +type family VarsLen vars :: Nat where + VarsLen '[] = 0 + VarsLen (_ ': vars) = 1 + VarsLen vars + +-- | Get the length of a 'Vars' list for a 'Path' or 'Params', +-- computed at compile-time. +-- +-- >>> knownVarsLen (1 ::: "a" ::: 3.14 ::: Nil) +-- 3 +-- +-- >>> knownVarsLen (str "a" ./ some @Int ./ var @"x" @Text ./ str "b" ./ end) +-- 2 +knownVarsLen :: forall proxy vars. KnownNat (VarsLen vars) => proxy vars -> Integer +knownVarsLen _ = natVal' (proxy# :: Proxy# (VarsLen vars)) + +-- | Get and parse the request method as a 'StdMethod'. +getMethod :: Request -> Either ByteString StdMethod +getMethod = parseMethod . requestMethod + +-- | Dispatch a request to an application based on the standardised +-- HTTP request methods (verbs). If the request method is not a +-- standard method, 'app405' is called. +byMethod :: (StdMethod -> App m) -> App m +byMethod f rq k = case getMethod rq of + Left _ -> app405 rq k + Right m -> f m rq k + +-- | Run an 'App' only if the request method matches, otherwise run 'app405'. +withMethod :: Monad m => StdMethod -> App m -> App m +withMethod m app = byMethod $ \m' -> + if m == m' then app + else app405 + +-- | Get and parse a query parameter by its name, assuming UTF-8 +-- encoding of the value. If the query parameter is not present in the +-- request or has an empty value, 'Nothing' is returned. +-- +-- If the parameter name is known to contain only ASCII characters (the most +-- common case), this function is more efficient than 'getQueryParam\'', since +-- query parameter names are plain 'ByteString's in the WAI. +getQueryParam :: FromHttpApiData a => Request -> ByteString -> Maybe (Either InvalidParam a) +getQueryParam rq key = case Prelude.lookup key (queryString rq) of + Nothing -> Nothing -- key not present + Just Nothing -> Nothing -- empty value + Just (Just bs) -> Just $! parseQParam (C8.unpack key) bs + +-- | Like 'getQueryParam' but supports UTF-8 encoded names of query parameters. +getQueryParam' :: FromHttpApiData a => Request -> Text -> Maybe (Either InvalidParam a) +getQueryParam' rq = getQueryParam rq . encodeUtf8 + +-- | A header that failed to parse. +data InvalidHeader = InvalidHeader + { invalidHeaderName :: HeaderName + , invalidHeaderValue :: ByteString + , invalidHeaderMsg :: Text + } deriving (Eq, Show, Read) + +-- | Get an parse the value of an HTTP header. +getHeader :: FromHttpApiData a => Request -> HeaderName -> Maybe (Either InvalidHeader a) +getHeader rq h = case Prelude.lookup h (requestHeaders rq) of + Nothing -> Nothing + Just bs -> case parseHeader bs of + Right a -> Just (Right a) + Left e -> Just (Left (InvalidHeader h bs e)) + +-- | An application that always yields a 400 Bad Request +-- plaintext response for an invalid parameter. +appInvalidParam :: InvalidParam -> App m +appInvalidParam (InvalidParam n v e) _rq k = + k $ responseLBS code hdrs body + where + code = status400 + hdrs = [(hContentType, "text/plain; charset=utf-8")] + body = LazyText.encodeUtf8 . toLazyText $ + fromString "Invalid parameter " + <> fromString "[" + <> (if not (null n) + then fromString n <> fromString "=" + else mempty) + <> fromText v + <> fromString "], " + <> fromText e + +-- | An application that always yields a 400 Bad Request +-- plaintext response for a missing parameter. +appMissingParam :: ParamName -> App m +appMissingParam name _rq k = + k $ responseLBS code hdrs body + where + code = status400 + hdrs = [(hContentType, "text/plain; charset=utf-8")] + body = LazyText.encodeUtf8 . toLazyText $ + fromString "Missing parameter " + <> fromString "[" + <> fromString name + <> fromString "]" + +-- | An application that always yields a 400 Bad Request +-- plaintext response for an invalid or missing query parameter. +appQueryError :: QueryError -> App m +appQueryError (QueryInvalidParam e) = appInvalidParam e +appQueryError (QueryMissingParam n) = appMissingParam n + +-- | An application that always yields an empty 404 Not Found response. +app404 :: App m +app404 _rq k = k $ responseLBS status404 [] mempty + +-- | An application that always yields an empty 405 Method Not Allowed response. +app405 :: App m +app405 _rq k = k $ responseLBS status405 [] mempty + +-- | An application that always yields an empty 400 Bad Request response. +app400 :: App m +app400 _rq k = k $ responseLBS status400 [] mempty diff --git a/src/Network/Wai/Route/Tree.hs b/src/Network/Wai/Route/Tree.hs deleted file mode 100644 --- a/src/Network/Wai/Route/Tree.hs +++ /dev/null @@ -1,129 +0,0 @@ --- This Source Code Form is subject to the terms of the Mozilla Public --- License, v. 2.0. If a copy of the MPL was not distributed with this --- file, You can obtain one at http://mozilla.org/MPL/2.0/. - -module Network.Wai.Route.Tree - ( -- * Routing Tree - Tree - , fromList - , lookup - , foldTree - , mapTree - , toList - , segments - - -- ** Tree leaf payload - , Payload - , value - , path - , captures - - -- ** Captures - , Captures - , captured - , captureParams - , captureValues - ) where - -import Control.Applicative -import Data.ByteString (ByteString) -import Data.List (foldl') -import Data.HashMap.Strict (HashMap) -import Data.Maybe (fromMaybe) -import Data.Semigroup -import Data.Word -import Network.HTTP.Types (urlDecode, urlEncode) -import Prelude hiding (lookup) - -import qualified Data.ByteString as B -import qualified Data.HashMap.Strict as M - -data Tree a = Tree - { subtree :: HashMap ByteString (Tree a) - , capture :: Maybe (Tree a) - , payload :: Maybe (Payload a) - } deriving (Eq, Show) - -data Payload a = Payload - { path :: !ByteString - , value :: !a - , captures :: !Captures - } deriving (Eq, Show) - -data Captures = Captures - { params :: [ByteString] - , values :: [ByteString] - } deriving (Eq, Show) - -instance Semigroup (Tree a) where - a <> b = Tree (subtree a <> subtree b) - (capture a <> capture b) - (payload a <|> payload b) - -instance Monoid (Tree a) where - mempty = Tree mempty Nothing Nothing - mappend = (<>) - -captureParams :: Captures -> [ByteString] -captureParams = params - -captureValues :: Captures -> [ByteString] -captureValues = values - -captured :: Captures -> [(ByteString, ByteString)] -captured (Captures a b) = zip a b - -fromList :: [(ByteString, a)] -> Tree a -fromList = foldl' addRoute mempty - where - addRoute t (p,a) = go t (segments p) [] - where - go n [] cs = - let pa = Payload p a (Captures cs []) - in n { payload = Just pa } - - go n (c:ps) cs | B.head c == colon = - let b = fromMaybe mempty $ capture n - in n { capture = Just $! go b ps (B.tail c : cs) } - - go n (d:ps) cs = - let d' = urlEncode False d - b = fromMaybe mempty $ M.lookup d' (subtree n) - in n { subtree = M.insert d' (go b ps cs) (subtree n) } - -lookup :: Tree a -> [ByteString] -> Maybe (Payload a) -lookup t p = go p [] t - where - go [] cvs n = - let f e = e { captures = Captures (params (captures e)) cvs } - in f <$> payload n - - go (s:ss) cvs n = - maybe (capture n >>= go ss (urlDecode False s : cvs)) - (go ss cvs) - (M.lookup s $ subtree n) - -foldTree :: (Payload a -> b -> b) -> b -> Tree a -> b -foldTree f z (Tree sub cap pay) = - let a = M.foldl' (foldTree f) z sub - b = maybe a (foldTree f a) cap - c = maybe b (flip f b) pay - in c - -mapTree :: (Payload a -> Payload b) -> Tree a -> Tree b -mapTree f t = foldTree apply mempty t - where - apply x tr = tr { payload = Just (f x) } - -toList :: Tree a -> [Payload a] -toList = foldTree (:) [] - -segments :: ByteString -> [ByteString] -segments = filter (not . B.null) . B.split slash - -slash, colon :: Word8 -slash = 0x2F -colon = 0x3A -{-# INLINE slash #-} -{-# INLINE colon #-} - diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,4 +8,4 @@ import qualified Test.Network.Wai.Route as Route main :: IO () -main = defaultMain $ testGroup "Tests" [ Route.tests ] +main = defaultMain Route.tests diff --git a/test/Test/Network/Wai/Route.hs b/test/Test/Network/Wai/Route.hs --- a/test/Test/Network/Wai/Route.hs +++ b/test/Test/Network/Wai/Route.hs @@ -2,132 +2,203 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE + OverloadedStrings + , TypeApplications +#-} module Test.Network.Wai.Route (tests) where +import Control.DeepSeq import Control.Monad.State.Strict -import Data.ByteString (ByteString) -import Data.Semigroup +import Data.Foldable (toList) +import Data.Sequence (Seq (..), (<|)) +import Data.Semigroup ((<>)) +import Data.Text (Text) import Network.HTTP.Types import Network.Wai import Network.Wai.Internal (ResponseReceived (..)) import Network.Wai.Route -import Network.Wai.Route.Tree (Tree) import Test.Tasty import Test.Tasty.QuickCheck -import qualified Data.ByteString.Char8 as C -import qualified Network.Wai.Route.Tree as Tree +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Trie.Pattern as Trie tests :: TestTree tests = testGroup "Network.Wai.Route" [ testProperty "route" checkRouting - , testGroup "Network.Wai.Route.Tree" - [ testProperty "identity" checkMonoidId - , testProperty "associativity" checkMonoidAssoc - ] + , testProperty "parsePath (1/2)" checkParsePath1 + , testProperty "parsePath (2/2)" checkParsePath2 + , testProperty "compileRoutes" checkCompileRoutes + , testProperty "path equivalence (=~=)" checkPathEquiv ] checkRouting :: Property -checkRouting = forAll genRoutes check +checkRouting = forAll genTestRoutes check where - check routes = - let f = route $ map (fmap unHandler) routes + check rs = + let f = route $ Trie.fromAssocList (map unTestRoute rs) k = const $ return ResponseReceived - in conjoin . flip map routes $ \(p, h) -> - forAll (genReq p) $ \(params, rq) -> - let s = execState (f rq k) (-1, []) - in s == (handlerId h, params) + in conjoin . flip map rs $ \(TestRoute (p, _)) -> + forAll (genRequest p) $ \(params, rq) -> + let s = execState (f noRoute rq k) (Seq.empty, Seq.empty) + in s == (p, params) -checkMonoidId :: Property -checkMonoidId = forAll genTree $ \t -> - t <> mempty == t && mempty <> t == t + noRoute _rq k = k $ responseLBS status404 [] mempty -checkMonoidAssoc :: Property -checkMonoidAssoc = forAll (replicateM 3 genTree) $ \[t1,t2,t3] -> - (t1 <> t2) <> t3 == t1 <> (t2 <> t3) +checkParsePath1 :: Property +checkParsePath1 = forAll (genPath Nothing) $ \(SomePath p) -> + let captures = Seq.replicate (pathVarsLen p) joker + in case parsePath p captures of + Left e -> counterexample (show e) False + Right _ -> property True +checkParsePath2 :: Property +checkParsePath2 = forAll ((,) <$> genText <*> arbitrary) $ \(t, i) -> + let + p0 = str t ./ end + p1 = str t ./ some @Int ./ end + c = Seq.singleton (Capture (Text.pack (show i))) + c' = Seq.singleton (Capture "NaN") + in + parsePath p0 c == Right Nil && + parsePath p0 Seq.empty == Right Nil && + parsePath p1 c == Right (i ::: Nil) && + parsePath p1 Seq.empty == Left PathMissingParams && + case parsePath p1 c' of + Left (PathInvalidParam e) -> invalidParamValue e == "NaN" + _ -> False + +-- | Compile a list of (non-overlapping) routes into a routing +-- trie and check that all routes have been preserved by running +-- all handlers. +checkCompileRoutes :: Property +checkCompileRoutes = forAll genRoutes $ \rs -> + let maxLen = maximum (map (Seq.length . routePattern) rs) + captures = Seq.replicate maxLen joker + rt = force $ run captures <$> compileRoutes rs + in Set.fromList (map Trie.matchOrd (toList rt)) + == + Set.fromList (map (Trie.matchOrd . routePattern) rs) + where + routePattern Route{routePath = p} = pathPattern p + + run captures h = + let k = const $ return ResponseReceived + s = h captures defaultRequest k + in execState s Seq.empty + +checkPathEquiv :: Property +checkPathEquiv = forAll ((,) <$> genPath Nothing <*> genPath Nothing) $ + \(SomePath p, SomePath p') -> + let pp = pathPattern p + pp' = pathPattern p' + in p =~= p' ==> pp == pp' + && + pp == pp' ==> p =~= p' + ------------------------------------------------------------------------------- -- Generators & helpers -type Params = [(ByteString, ByteString)] +type TestState = State (Pattern Text, Seq (Capture Text)) -data TestHandler = TestHandler - { handlerId :: !Int - , unHandler :: Handler (State (Int, Params)) - } +-- | An (untyped) test route. +newtype TestRoute = TestRoute + { unTestRoute :: (Pattern Text, Handler TestState) } -instance Eq TestHandler where - h1 == h2 = handlerId h1 == handlerId h2 +instance Show TestRoute where + show (TestRoute (p, _)) = "" -instance Show TestHandler where - show h = "" +-- Generate a matcher for a pattern. All 'EqStr' matchers are prefixed +-- with a @0@ character, to avoid accidental clashes with generated +-- capture values (see 'genRequest'). +genMatcher :: Gen (Matcher Text) +genMatcher = oneof [genStr, genVar] + where + genStr = EqStr . ("0" <>) <$> genText + genVar = pure AnyStr -handler :: Int -> TestHandler -handler i = TestHandler i $ \p _ k -> do - put (i, p) - k $ responseLBS status200 [] mempty +genPattern :: Gen (Pattern Text) +genPattern = do + n <- choose (1, 10) + Seq.fromList <$> vectorOf n genMatcher --- Generate a name for a capture segment in a route. -genCapture :: Gen ByteString -genCapture = (":"<>) . C.pack <$> listOf1 arbitraryASCIIChar `suchThat` f - where - f d = '/' `notElem` d +genPath :: Maybe Text -> Gen SomePath +genPath prefix = oneof + [ return (SomePath (maybe id str prefix $ end)) + , do SomePath p <- genPath prefix + SomePath <$> (str <$> genText <*> pure p) + , do SomePath p <- genPath prefix + b <- elements [True,False] + return $ if b + then SomePath (some @Text p) + else SomePath (some @Int p) + ] --- Generate a name for a static segment in a route. These are disambiguated from --- generated parameter values by a fixed prefix, namely '_'. See 'genParam'. -genDir :: Gen ByteString -genDir = C.pack . ('_':) <$> listOf1 arbitraryASCIIChar `suchThat` f - where - f d = head d /= ':' && '/' `notElem` d +-- | A capture value that is valid for all types in a path +-- generated by 'genPath'. +joker :: Capture Text +joker = Capture "42" --- Generate a parameter value for a capture segment to be used in a request. --- These are disambiguated from static segments by a fixed prefix, namely 'p', --- in order not to generate values that accidentily match a static segment of --- some other route. -genParam :: Gen ByteString -genParam = C.pack . ('p':) <$> listOf1 arbitraryASCIIChar +genTestRoute :: Gen TestRoute +genTestRoute = do + p <- genPattern + return $ TestRoute (p, \params _ k -> do + put (p, params) + k $ responseLBS status200 [] mempty) -genRoute :: ByteString -> Gen ByteString +genTestRoutes :: Gen [TestRoute] +genTestRoutes = do + n <- choose (0, 100) + replicateM n genTestRoute + +genRoute :: Maybe Text -> Gen (Route (State (Pattern Text))) genRoute prefix = do - n <- choose (1, 10) - s <- vectorOf n (oneof [genDir, genCapture]) - return $ prefix <> C.intercalate "/" s + SomePath p <- genPath prefix + return $ defRoute p $ \_params _rq k -> do + put (pathPattern p) + k $ responseLBS status200 [] mempty --- Generates routing tables without ambiguous routes (by giving every route a --- prefix that is unique in this routing table). -genRoutes :: Gen [(ByteString, TestHandler)] +-- | Generate 1-100 non-overlapping routes. +genRoutes :: Gen [Route (State (Pattern Text))] genRoutes = do - n <- choose (0, 100) - r <- mapM (genRoute . C.pack . show) [1..n] - return $ r `zip` map handler [1..n] - -genTree :: Gen (Tree TestHandler) -genTree = Tree.fromList <$> genRoutes + n <- choose (0 :: Int, 100) + mapM (genRoute . Just . Text.pack . show) [1..n] --- Generate a request with a path matching the given route, --- replacing captures with actual parameter values. -genReq :: ByteString -> Gen (Params, Request) -genReq r = do +-- Generate a request with a path matching the given pattern, +-- generating capture values for capture segments. Returns the +-- generated captures and request. +genRequest :: Pattern Text -> Gen (Seq (Capture Text), Request) +genRequest pat = do -- Pair each segment of the route with a potential parameter value. -- Those values which are paired with a capture are the actual parameters. - let segs = C.split '/' r - values <- vectorOf (length segs) genParam - let segs' = segs `zip` values - return (mkParams segs', mkReq segs') + values <- vectorOf (Seq.length pat) genValue + let segs = toList pat `zip` values + return (mkParams segs, mkReq segs) where mkReq segs = defaultRequest - { rawPathInfo = C.intercalate "/" (map mkSeg segs) + { pathInfo = map mkSeg segs } - mkSeg (seg, val) - | C.head seg == ':' = urlEncode False val - | otherwise = urlEncode False seg + mkSeg (AnyStr, val) = val + mkSeg (EqStr s, _) = s - mkParams = reverse . foldr go [] + mkParams = foldr go Seq.empty where - go (seg, val) params - | C.head seg == ':' = (C.tail seg, val) : params - | otherwise = params + go (AnyStr, val) ps = Capture val <| ps + go (EqStr _, _) ps = ps + +-- Generate a value for a capture. All values are prefixed with +-- a '1' character, to avoid accidentally generating a value that is +-- an exact match for an 'EqStr' matcher in another pattern. If that +-- were to happen for all matchers of a path (unlikely but possible), +-- it would result in a spurious test failure. +genValue :: Gen Text +genValue = ("1" <>) <$> genText + +genText :: Gen Text +genText = Text.pack <$> listOf arbitrary diff --git a/wai-route.cabal b/wai-route.cabal --- a/wai-route.cabal +++ b/wai-route.cabal @@ -1,78 +1,88 @@ -name: wai-route -version: 0.4.0 -synopsis: Minimalistic, efficient routing for WAI. +name: wai-route +version: 1.0.0 +synopsis: WAI middleware for path-based request routing with captures. +category: Web description: - . - Simple routing for applications using the WAI, based on an - efficient tree structure. Routes are defined as string literals - whereby path segments beginning with a ':' indicate captures. - . - A sample is available at: . + WAI middleware for path-based request routing with captures, + including further utilities for processing query strings and + request headers. -license: MPL-2.0 -license-file: LICENSE -author: Roman S. Borschel -maintainer: Roman S. Borschel -copyright: 2014 Roman S. Borschel -category: Web -build-type: Simple -extra-source-files: README.md, sample/*.hs, CHANGELOG.md -cabal-version: >=1.10 +license: MPL-2.0 +license-file: LICENSE +author: Roman S. Borschel +maintainer: Roman S. Borschel +copyright: 2018 Roman S. Borschel -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +build-type: Simple +cabal-version: 1.18 +tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2 + +extra-source-files: + README.md, CHANGELOG.md, examples/*.hs + source-repository head type: git location: git@github.com:romanb/wai-route.git library default-language: Haskell2010 - hs-source-dirs: src + hs-source-dirs: src exposed-modules: Network.Wai.Route - , Network.Wai.Route.Tree + default-extensions: + NoImplicitPrelude + build-depends: - base == 4.* - , wai >= 3.0.2 && < 3.3 - , unordered-containers >= 0.2 - , http-types >= 0.8 + base >= 4.9 && < 5 , bytestring >= 0.10 + , containers >= 0.5.7 + , deepseq >= 1.4.3 + , http-api-data >= 0.3 + , http-types >= 0.8 + , pattern-trie >= 0.1 + , text + , unordered-containers >= 0.2 + , wai >= 3.0.2 && < 3.3 ghc-options: -Wall -fwarn-tabs - -O2 test-suite wai-route-test - type: exitcode-stdio-1.0 default-language: Haskell2010 - hs-source-dirs: test - main-is: Main.hs - ghc-options: - -Wall - -fwarn-tabs - -threaded - other-modules: Test.Network.Wai.Route + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + other-modules: + Test.Network.Wai.Route + build-depends: - base == 4.* + base == 4.* , bytestring + , containers + , deepseq , http-types - , mtl >= 2.1 - , QuickCheck >= 2.10 - , tasty >= 0.11 + , mtl >= 2.1 + , pattern-trie + , QuickCheck >= 2.10 + , tasty >= 0.11 , tasty-quickcheck >= 0.9 + , text + , unordered-containers , wai , wai-route --- executable wai-route-sample --- hs-source-dirs: sample --- main-is: Main.hs --- build-depends: --- base --- , bytestring --- , http-types --- , wai --- , wai-route --- , warp + ghc-options: + -Wall + -fwarn-tabs + -threaded + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: base, doctest >= 0.16