Improvements and visualization of router structure.
* Improves how Routers are built, in particular via the `choice` smart constructors. Static lookups are now used more often. * We now have test cases making sure that certain routers have the same structure. * The router structure can now be visualized for debugging purposes as a tree. The new functions `layout` and `layoutWithContext` do this.
This commit is contained in:
parent
ba57d20008
commit
8c778825c7
7 changed files with 527 additions and 109 deletions
|
@ -1,3 +1,12 @@
|
||||||
|
0.7
|
||||||
|
---
|
||||||
|
|
||||||
|
* The `Router` type has been changed. There are now more situations where
|
||||||
|
servers will make use of static lookups to efficiently route the request
|
||||||
|
to the correct endpoint. Functions `layout` and `layoutWithContext` have
|
||||||
|
been added to visualize the router layout for debugging purposes. Test
|
||||||
|
cases for expected router layouts have been added.
|
||||||
|
|
||||||
0.6.1
|
0.6.1
|
||||||
-----
|
-----
|
||||||
|
|
||||||
|
|
|
@ -18,6 +18,10 @@ module Servant.Server
|
||||||
HasServer(..)
|
HasServer(..)
|
||||||
, Server
|
, Server
|
||||||
|
|
||||||
|
-- * Debugging the server layout
|
||||||
|
, layout
|
||||||
|
, layoutWithContext
|
||||||
|
|
||||||
-- * Enter
|
-- * Enter
|
||||||
-- $enterDoc
|
-- $enterDoc
|
||||||
|
|
||||||
|
@ -93,6 +97,7 @@ module Servant.Server
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Proxy (Proxy)
|
import Data.Proxy (Proxy)
|
||||||
|
import Data.Text (Text)
|
||||||
import Network.Wai (Application)
|
import Network.Wai (Application)
|
||||||
import Servant.Server.Internal
|
import Servant.Server.Internal
|
||||||
import Servant.Server.Internal.Enter
|
import Servant.Server.Internal.Enter
|
||||||
|
@ -131,6 +136,73 @@ serveWithContext p context server = toApplication (runRouter (route p context d)
|
||||||
d = Delayed r r r r (\ _ _ _ -> Route server)
|
d = Delayed r r r r (\ _ _ _ -> Route server)
|
||||||
r = return (Route ())
|
r = return (Route ())
|
||||||
|
|
||||||
|
-- | The function 'layout' produces a textual description of the internal
|
||||||
|
-- router layout for debugging purposes. Note that the router layout is
|
||||||
|
-- determined just by the API, not by the handlers.
|
||||||
|
--
|
||||||
|
-- This function makes certain assumptions about the well-behavedness of
|
||||||
|
-- the 'HasServer' instances of the combinators which should be ok for the
|
||||||
|
-- core servant constructions, but might not be satisfied for some other
|
||||||
|
-- combinators provided elsewhere. It is possible that the function may
|
||||||
|
-- crash for these.
|
||||||
|
--
|
||||||
|
-- Example:
|
||||||
|
--
|
||||||
|
-- For the following API
|
||||||
|
--
|
||||||
|
-- > type API =
|
||||||
|
-- > "a" :> "d" :> Get '[JSON] ()
|
||||||
|
-- > :<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
|
||||||
|
-- > :<|> "c" :> Put '[JSON] Bool
|
||||||
|
-- > :<|> "a" :> "e" :> Get '[JSON] Int
|
||||||
|
-- > :<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
|
||||||
|
-- > :<|> Raw
|
||||||
|
--
|
||||||
|
-- we get the following output:
|
||||||
|
--
|
||||||
|
-- > /
|
||||||
|
-- > ├─ a/
|
||||||
|
-- > │ ├─ d/
|
||||||
|
-- > │ │ └─•
|
||||||
|
-- > │ └─ e/
|
||||||
|
-- > │ └─•
|
||||||
|
-- > ├─ b/
|
||||||
|
-- > │ └─ <dyn>/
|
||||||
|
-- > │ ├─•
|
||||||
|
-- > │ ┆
|
||||||
|
-- > │ └─•
|
||||||
|
-- > ├─ c/
|
||||||
|
-- > │ └─•
|
||||||
|
-- > ┆
|
||||||
|
-- > └─ <raw>
|
||||||
|
--
|
||||||
|
-- Explanation of symbols:
|
||||||
|
--
|
||||||
|
-- [@├@] Normal lines reflect static branching via a table.
|
||||||
|
--
|
||||||
|
-- [@a/@] Nodes reflect static path components.
|
||||||
|
--
|
||||||
|
-- [@─•@] Leaves reflect endpoints.
|
||||||
|
--
|
||||||
|
-- [@\<dyn\>/@] This is a delayed capture of a path component.
|
||||||
|
--
|
||||||
|
-- [@\<raw\>@] This is a part of the API we do not know anything about.
|
||||||
|
--
|
||||||
|
-- [@┆@] Dashed lines suggest a dynamic choice between the part above
|
||||||
|
-- and below. If there is a success for fatal failure in the first part,
|
||||||
|
-- that one takes precedence. If both parts fail, the \"better\" error
|
||||||
|
-- code will be returned.
|
||||||
|
--
|
||||||
|
layout :: (HasServer layout '[]) => Proxy layout -> Text
|
||||||
|
layout p = layoutWithContext p EmptyContext
|
||||||
|
|
||||||
|
-- | Variant of 'layout' that takes an additional 'Context'.
|
||||||
|
layoutWithContext :: (HasServer layout context)
|
||||||
|
=> Proxy layout -> Context context -> Text
|
||||||
|
layoutWithContext p context = routerLayout (route p context d)
|
||||||
|
where
|
||||||
|
d = Delayed r r r r (\ _ _ _ -> FailFatal err501)
|
||||||
|
r = return (Route ())
|
||||||
|
|
||||||
-- Documentation
|
-- Documentation
|
||||||
|
|
||||||
|
|
|
@ -26,11 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Char8 as BC8
|
import qualified Data.ByteString.Char8 as BC8
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
import Data.String.Conversions (cs, (<>))
|
import Data.String.Conversions (cs, (<>))
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
||||||
symbolVal)
|
symbolVal)
|
||||||
|
@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||||
import Network.Socket (SockAddr)
|
import Network.Socket (SockAddr)
|
||||||
import Network.Wai (Application, Request, Response,
|
import Network.Wai (Application, Request, Response,
|
||||||
httpVersion, isSecure,
|
httpVersion, isSecure,
|
||||||
lazyRequestBody, pathInfo,
|
lazyRequestBody,
|
||||||
rawQueryString, remoteHost,
|
rawQueryString, remoteHost,
|
||||||
requestHeaders, requestMethod,
|
requestHeaders, requestMethod,
|
||||||
responseLBS, vault)
|
responseLBS, vault)
|
||||||
|
@ -161,26 +159,23 @@ methodRouter :: (AllCTRender ctypes a)
|
||||||
=> Method -> Proxy ctypes -> Status
|
=> Method -> Proxy ctypes -> Status
|
||||||
-> Delayed (ExceptT ServantErr IO a)
|
-> Delayed (ExceptT ServantErr IO a)
|
||||||
-> Router
|
-> Router
|
||||||
methodRouter method proxy status action = LeafRouter route'
|
methodRouter method proxy status action = leafRouter route'
|
||||||
where
|
where
|
||||||
route' request respond
|
route' request respond =
|
||||||
| pathIsEmpty request =
|
|
||||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
in runAction (action `addMethodCheck` methodCheck method request
|
in runAction (action `addMethodCheck` methodCheck method request
|
||||||
`addAcceptCheck` acceptCheck proxy accH
|
`addAcceptCheck` acceptCheck proxy accH
|
||||||
) respond $ \ output -> do
|
) respond $ \ output -> do
|
||||||
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||||
processMethodRouter handleA status method Nothing request
|
processMethodRouter handleA status method Nothing request
|
||||||
| otherwise = respond $ Fail err404
|
|
||||||
|
|
||||||
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
||||||
=> Method -> Proxy ctypes -> Status
|
=> Method -> Proxy ctypes -> Status
|
||||||
-> Delayed (ExceptT ServantErr IO (Headers h v))
|
-> Delayed (ExceptT ServantErr IO (Headers h v))
|
||||||
-> Router
|
-> Router
|
||||||
methodRouterHeaders method proxy status action = LeafRouter route'
|
methodRouterHeaders method proxy status action = leafRouter route'
|
||||||
where
|
where
|
||||||
route' request respond
|
route' request respond =
|
||||||
| pathIsEmpty request =
|
|
||||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||||
in runAction (action `addMethodCheck` methodCheck method request
|
in runAction (action `addMethodCheck` methodCheck method request
|
||||||
`addAcceptCheck` acceptCheck proxy accH
|
`addAcceptCheck` acceptCheck proxy accH
|
||||||
|
@ -188,7 +183,6 @@ methodRouterHeaders method proxy status action = LeafRouter route'
|
||||||
let headers = getHeaders output
|
let headers = getHeaders output
|
||||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||||
processMethodRouter handleA status method (Just headers) request
|
processMethodRouter handleA status method (Just headers) request
|
||||||
| otherwise = respond $ Fail err404
|
|
||||||
|
|
||||||
instance OVERLAPPABLE_
|
instance OVERLAPPABLE_
|
||||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||||
|
@ -359,7 +353,7 @@ instance HasServer Raw context where
|
||||||
|
|
||||||
type ServerT Raw m = Application
|
type ServerT Raw m = Application
|
||||||
|
|
||||||
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
|
route Proxy _ rawApplication = RawRouter $ \ request respond -> do
|
||||||
r <- runDelayed rawApplication
|
r <- runDelayed rawApplication
|
||||||
case r of
|
case r of
|
||||||
Route app -> app request (respond . Route)
|
Route app -> app request (respond . Route)
|
||||||
|
@ -416,9 +410,10 @@ instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> s
|
||||||
|
|
||||||
type ServerT (path :> sublayout) m = ServerT sublayout m
|
type ServerT (path :> sublayout) m = ServerT sublayout m
|
||||||
|
|
||||||
route Proxy context subserver = StaticRouter $
|
route Proxy context subserver =
|
||||||
M.singleton (cs (symbolVal proxyPath))
|
pathRouter
|
||||||
(route (Proxy :: Proxy sublayout) context subserver)
|
(cs (symbolVal proxyPath))
|
||||||
|
(route (Proxy :: Proxy sublayout) context subserver)
|
||||||
where proxyPath = Proxy :: Proxy path
|
where proxyPath = Proxy :: Proxy path
|
||||||
|
|
||||||
instance HasServer api context => HasServer (RemoteHost :> api) context where
|
instance HasServer api context => HasServer (RemoteHost :> api) context where
|
||||||
|
@ -465,12 +460,6 @@ instance ( KnownSymbol realm
|
||||||
|
|
||||||
-- * helpers
|
-- * helpers
|
||||||
|
|
||||||
pathIsEmpty :: Request -> Bool
|
|
||||||
pathIsEmpty = go . pathInfo
|
|
||||||
where go [] = True
|
|
||||||
go [""] = True
|
|
||||||
go _ = False
|
|
||||||
|
|
||||||
ct_wildcard :: B.ByteString
|
ct_wildcard :: B.ByteString
|
||||||
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,13 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Servant.Server.Internal.Router where
|
module Servant.Server.Internal.Router where
|
||||||
|
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
import Data.Monoid
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as T
|
||||||
import Network.Wai (Request, Response, pathInfo)
|
import Network.Wai (Request, Response, pathInfo)
|
||||||
import Servant.Server.Internal.RoutingApplication
|
import Servant.Server.Internal.RoutingApplication
|
||||||
import Servant.Server.Internal.ServantErr
|
import Servant.Server.Internal.ServantErr
|
||||||
|
@ -13,36 +16,46 @@ type Router = Router' RoutingApplication
|
||||||
|
|
||||||
-- | Internal representation of a router.
|
-- | Internal representation of a router.
|
||||||
data Router' a =
|
data Router' a =
|
||||||
WithRequest (Request -> Router)
|
WithRequest (Request -> Router' a)
|
||||||
-- ^ current request is passed to the router
|
-- ^ current request is passed to the router
|
||||||
| StaticRouter (Map Text Router)
|
| StaticRouter (Map Text (Router' a)) [a]
|
||||||
-- ^ first path component used for lookup and removed afterwards
|
-- ^ the map contains routers for subpaths (first path component used
|
||||||
| DynamicRouter (Text -> Router)
|
-- for lookup and removed afterwards), the list contains handlers
|
||||||
-- ^ first path component used for lookup and removed afterwards
|
-- for the empty path, to be tried in order
|
||||||
| LeafRouter a
|
| DynamicRouter (Text -> Router' a)
|
||||||
-- ^ to be used for routes that match an empty path
|
-- ^ first path component passed to the function and removed afterwards
|
||||||
| Choice Router Router
|
| RawRouter a
|
||||||
|
-- ^ to be used for routes we do not know anything about
|
||||||
|
| Choice (Router' a) (Router' a)
|
||||||
-- ^ left-biased choice between two routers
|
-- ^ left-biased choice between two routers
|
||||||
deriving Functor
|
deriving Functor
|
||||||
|
|
||||||
-- | Apply a transformation to the response of a `Router`.
|
-- | Smart constructor for a single static path component.
|
||||||
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
|
pathRouter :: Text -> Router' a -> Router' a
|
||||||
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
|
pathRouter t r = StaticRouter (M.singleton t r) []
|
||||||
|
|
||||||
|
-- | Smart constructor for a leaf, i.e., a router that expects
|
||||||
|
-- the empty path.
|
||||||
|
--
|
||||||
|
leafRouter :: a -> Router' a
|
||||||
|
leafRouter l = StaticRouter M.empty [l]
|
||||||
|
|
||||||
-- | Smart constructor for the choice between routers.
|
-- | Smart constructor for the choice between routers.
|
||||||
-- We currently optimize the following cases:
|
-- We currently optimize the following cases:
|
||||||
--
|
--
|
||||||
-- * Two static routers can be joined by joining their maps.
|
-- * Two static routers can be joined by joining their maps
|
||||||
|
-- and concatenating their leaf-lists.
|
||||||
-- * Two dynamic routers can be joined by joining their codomains.
|
-- * Two dynamic routers can be joined by joining their codomains.
|
||||||
-- * Two 'WithRequest' routers can be joined by passing them
|
-- * Two 'WithRequest' routers can be joined by passing them
|
||||||
-- the same request and joining their codomains.
|
-- the same request and joining their codomains.
|
||||||
-- * A 'WithRequest' router can be joined with anything else by
|
-- * A 'WithRequest' router can be joined with anything else by
|
||||||
-- passing the same request to both but ignoring it in the
|
-- passing the same request to both but ignoring it in the
|
||||||
-- component that does not need it.
|
-- component that does not need it.
|
||||||
|
-- * Choice nodes can be reordered.
|
||||||
--
|
--
|
||||||
choice :: Router -> Router -> Router
|
choice :: Router -> Router -> Router
|
||||||
choice (StaticRouter table1) (StaticRouter table2) =
|
choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
|
||||||
StaticRouter (M.unionWith choice table1 table2)
|
StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
|
||||||
choice (DynamicRouter fun1) (DynamicRouter fun2) =
|
choice (DynamicRouter fun1) (DynamicRouter fun2) =
|
||||||
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
|
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
|
||||||
choice (WithRequest router1) (WithRequest router2) =
|
choice (WithRequest router1) (WithRequest router2) =
|
||||||
|
@ -51,39 +64,136 @@ choice (WithRequest router1) router2 =
|
||||||
WithRequest (\ request -> choice (router1 request) router2)
|
WithRequest (\ request -> choice (router1 request) router2)
|
||||||
choice router1 (WithRequest router2) =
|
choice router1 (WithRequest router2) =
|
||||||
WithRequest (\ request -> choice router1 (router2 request))
|
WithRequest (\ request -> choice router1 (router2 request))
|
||||||
|
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
|
||||||
choice router1 router2 = Choice router1 router2
|
choice router1 router2 = Choice router1 router2
|
||||||
|
|
||||||
|
-- | Datatype used for representing and debugging the
|
||||||
|
-- structure of a router. Abstracts from the functions
|
||||||
|
-- being used in the actual router and the handlers at
|
||||||
|
-- the leaves.
|
||||||
|
--
|
||||||
|
-- Two 'Router's can be structurally compared by computing
|
||||||
|
-- their 'RouterStructure' using 'routerStructure' and
|
||||||
|
-- then testing for equality, see 'sameStructure'.
|
||||||
|
--
|
||||||
|
data RouterStructure =
|
||||||
|
WithRequestStructure RouterStructure
|
||||||
|
| StaticRouterStructure (Map Text RouterStructure) Int
|
||||||
|
| DynamicRouterStructure RouterStructure
|
||||||
|
| RawRouterStructure
|
||||||
|
| ChoiceStructure RouterStructure RouterStructure
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- | Compute the structure of a router.
|
||||||
|
--
|
||||||
|
-- Assumes that the request or text being passed
|
||||||
|
-- in 'WithRequest' or 'DynamicRouter' does not
|
||||||
|
-- affect the structure of the underlying tree.
|
||||||
|
--
|
||||||
|
routerStructure :: Router' a -> RouterStructure
|
||||||
|
routerStructure (WithRequest f) =
|
||||||
|
WithRequestStructure $
|
||||||
|
routerStructure (f (error "routerStructure: dummy request"))
|
||||||
|
routerStructure (StaticRouter m ls) =
|
||||||
|
StaticRouterStructure (fmap routerStructure m) (length ls)
|
||||||
|
routerStructure (DynamicRouter f) =
|
||||||
|
DynamicRouterStructure $
|
||||||
|
routerStructure (f (error "routerStructure: dummy text"))
|
||||||
|
routerStructure (RawRouter _) =
|
||||||
|
RawRouterStructure
|
||||||
|
routerStructure (Choice r1 r2) =
|
||||||
|
ChoiceStructure
|
||||||
|
(routerStructure r1)
|
||||||
|
(routerStructure r2)
|
||||||
|
|
||||||
|
-- | Compare the structure of two routers.
|
||||||
|
--
|
||||||
|
sameStructure :: Router' a -> Router' b -> Bool
|
||||||
|
sameStructure r1 r2 =
|
||||||
|
routerStructure r1 == routerStructure r2
|
||||||
|
|
||||||
|
-- | Provide a textual representation of the
|
||||||
|
-- structure of a router.
|
||||||
|
--
|
||||||
|
routerLayout :: Router' a -> Text
|
||||||
|
routerLayout router =
|
||||||
|
T.unlines (["/"] ++ mkRouterLayout False (routerStructure router))
|
||||||
|
where
|
||||||
|
mkRouterLayout :: Bool -> RouterStructure -> [Text]
|
||||||
|
mkRouterLayout c (WithRequestStructure r) = mkRouterLayout c r
|
||||||
|
mkRouterLayout c (StaticRouterStructure m n) = mkSubTrees c (M.toList m) n
|
||||||
|
mkRouterLayout c (DynamicRouterStructure r) = mkSubTree c "<dyn>" (mkRouterLayout False r)
|
||||||
|
mkRouterLayout c RawRouterStructure =
|
||||||
|
if c then ["├─ <raw>"] else ["└─ <raw>"]
|
||||||
|
mkRouterLayout c (ChoiceStructure r1 r2) =
|
||||||
|
mkRouterLayout True r1 ++ ["┆"] ++ mkRouterLayout c r2
|
||||||
|
|
||||||
|
mkSubTrees :: Bool -> [(Text, RouterStructure)] -> Int -> [Text]
|
||||||
|
mkSubTrees _ [] 0 = []
|
||||||
|
mkSubTrees c [] n =
|
||||||
|
concat (replicate (n - 1) (mkLeaf True) ++ [mkLeaf c])
|
||||||
|
mkSubTrees c [(t, r)] 0 =
|
||||||
|
mkSubTree c t (mkRouterLayout False r)
|
||||||
|
mkSubTrees c ((t, r) : trs) n =
|
||||||
|
mkSubTree True t (mkRouterLayout False r) ++ mkSubTrees c trs n
|
||||||
|
|
||||||
|
mkLeaf :: Bool -> [Text]
|
||||||
|
mkLeaf True = ["├─•","┆"]
|
||||||
|
mkLeaf False = ["└─•"]
|
||||||
|
|
||||||
|
mkSubTree :: Bool -> Text -> [Text] -> [Text]
|
||||||
|
mkSubTree True path children = ("├─ " <> path <> "/") : map ("│ " <>) children
|
||||||
|
mkSubTree False path children = ("└─ " <> path <> "/") : map (" " <>) children
|
||||||
|
|
||||||
|
-- | Apply a transformation to the response of a `Router`.
|
||||||
|
tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router -> Router
|
||||||
|
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
|
||||||
|
|
||||||
-- | Interpret a router as an application.
|
-- | Interpret a router as an application.
|
||||||
runRouter :: Router -> RoutingApplication
|
runRouter :: Router -> RoutingApplication
|
||||||
runRouter (WithRequest router) request respond =
|
runRouter (WithRequest router) request respond =
|
||||||
runRouter (router request) request respond
|
runRouter (router request) request respond
|
||||||
runRouter (StaticRouter table) request respond =
|
runRouter (StaticRouter table ls) request respond =
|
||||||
case pathInfo request of
|
case pathInfo request of
|
||||||
first : rest
|
[] -> runChoice ls request respond
|
||||||
| Just router <- M.lookup first table
|
-- This case is to handle trailing slashes.
|
||||||
|
[""] -> runChoice ls request respond
|
||||||
|
first : rest | Just router <- M.lookup first table
|
||||||
-> let request' = request { pathInfo = rest }
|
-> let request' = request { pathInfo = rest }
|
||||||
in runRouter router request' respond
|
in runRouter router request' respond
|
||||||
_ -> respond $ Fail err404
|
_ -> respond $ Fail err404
|
||||||
runRouter (DynamicRouter fun) request respond =
|
runRouter (DynamicRouter fun) request respond =
|
||||||
case pathInfo request of
|
case pathInfo request of
|
||||||
|
[] -> respond $ Fail err404
|
||||||
|
-- This case is to handle trailing slashes.
|
||||||
|
[""] -> respond $ Fail err404
|
||||||
first : rest
|
first : rest
|
||||||
-> let request' = request { pathInfo = rest }
|
-> let request' = request { pathInfo = rest }
|
||||||
in runRouter (fun first) request' respond
|
in runRouter (fun first) request' respond
|
||||||
_ -> respond $ Fail err404
|
runRouter (RawRouter app) request respond = app request respond
|
||||||
runRouter (LeafRouter app) request respond = app request respond
|
|
||||||
runRouter (Choice r1 r2) request respond =
|
runRouter (Choice r1 r2) request respond =
|
||||||
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
|
runChoice [runRouter r1, runRouter r2] request respond
|
||||||
Fail _ -> runRouter r2 request $ \ mResponse2 ->
|
|
||||||
respond (highestPri mResponse1 mResponse2)
|
|
||||||
_ -> respond mResponse1
|
|
||||||
where
|
|
||||||
highestPri (Fail e1) (Fail e2) =
|
|
||||||
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
|
|
||||||
then Fail e2
|
|
||||||
else Fail e1
|
|
||||||
highestPri (Fail _) y = y
|
|
||||||
highestPri x _ = x
|
|
||||||
|
|
||||||
|
-- | Try a list of routing applications in order.
|
||||||
|
-- We stop as soon as one fails fatally or succeeds.
|
||||||
|
-- If all fail normally, we pick the "best" error.
|
||||||
|
--
|
||||||
|
runChoice :: [RoutingApplication] -> RoutingApplication
|
||||||
|
runChoice [] _request respond = respond (Fail err404)
|
||||||
|
runChoice [r] request respond = r request respond
|
||||||
|
runChoice (r : rs) request respond =
|
||||||
|
r request $ \ response1 ->
|
||||||
|
case response1 of
|
||||||
|
Fail _ -> runChoice rs request $ \ response2 ->
|
||||||
|
respond $ highestPri response1 response2
|
||||||
|
_ -> respond response1
|
||||||
|
where
|
||||||
|
highestPri (Fail e1) (Fail e2) =
|
||||||
|
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
|
||||||
|
then Fail e2
|
||||||
|
else Fail e1
|
||||||
|
highestPri (Fail _) y = y
|
||||||
|
highestPri x _ = x
|
||||||
|
|
||||||
-- Priority on HTTP codes.
|
-- Priority on HTTP codes.
|
||||||
--
|
--
|
||||||
|
|
|
@ -35,31 +35,6 @@ toApplication ra request respond = ra request routingRespond
|
||||||
routingRespond (FailFatal err) = respond $ responseServantErr err
|
routingRespond (FailFatal err) = respond $ responseServantErr err
|
||||||
routingRespond (Route v) = respond v
|
routingRespond (Route v) = respond v
|
||||||
|
|
||||||
-- We currently mix up the order in which we perform checks
|
|
||||||
-- and the priority with which errors are reported.
|
|
||||||
--
|
|
||||||
-- For example, we perform Capture checks prior to method checks,
|
|
||||||
-- and therefore get 404 before 405.
|
|
||||||
--
|
|
||||||
-- However, we also perform body checks prior to method checks
|
|
||||||
-- now, and therefore get 415 before 405, which is wrong.
|
|
||||||
--
|
|
||||||
-- If we delay Captures, but perform method checks eagerly, we
|
|
||||||
-- end up potentially preferring 405 over 404, which is also bad.
|
|
||||||
--
|
|
||||||
-- So in principle, we'd like:
|
|
||||||
--
|
|
||||||
-- static routes (can cause 404)
|
|
||||||
-- delayed captures (can cause 404)
|
|
||||||
-- methods (can cause 405)
|
|
||||||
-- authentication and authorization (can cause 401, 403)
|
|
||||||
-- delayed body (can cause 415, 400)
|
|
||||||
-- accept header (can cause 406)
|
|
||||||
--
|
|
||||||
-- According to the HTTP decision diagram, the priority order
|
|
||||||
-- between HTTP status codes is as follows:
|
|
||||||
--
|
|
||||||
|
|
||||||
-- | A 'Delayed' is a representation of a handler with scheduled
|
-- | A 'Delayed' is a representation of a handler with scheduled
|
||||||
-- delayed checks that can trigger errors.
|
-- delayed checks that can trigger errors.
|
||||||
--
|
--
|
||||||
|
|
295
servant-server/test/Servant/Server/RouterSpec.hs
Normal file
295
servant-server/test/Servant/Server/RouterSpec.hs
Normal file
|
@ -0,0 +1,295 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
module Servant.Server.RouterSpec (spec) where
|
||||||
|
|
||||||
|
import Control.Monad (unless)
|
||||||
|
import Data.Proxy (Proxy(..))
|
||||||
|
import Data.Text (unpack)
|
||||||
|
import Network.HTTP.Types (Status (..))
|
||||||
|
import Network.Wai (Application, responseBuilder)
|
||||||
|
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||||
|
import Test.Hspec
|
||||||
|
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||||
|
import Servant.API
|
||||||
|
import Servant.Server
|
||||||
|
import Servant.Server.Internal
|
||||||
|
|
||||||
|
spec = describe "Servant.Server.Internal.Router" $ do
|
||||||
|
routerSpec
|
||||||
|
distributivitySpec
|
||||||
|
|
||||||
|
routerSpec :: Spec
|
||||||
|
routerSpec = do
|
||||||
|
let app' :: Application
|
||||||
|
app' = toApplication $ runRouter router'
|
||||||
|
|
||||||
|
router', router :: Router
|
||||||
|
router' = tweakResponse (fmap twk) router
|
||||||
|
router = leafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
|
||||||
|
|
||||||
|
twk :: Response -> Response
|
||||||
|
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
|
||||||
|
twk b = b
|
||||||
|
|
||||||
|
describe "tweakResponse" . with (return app') $ do
|
||||||
|
it "calls f on route result" $ do
|
||||||
|
get "" `shouldRespondWith` 202
|
||||||
|
|
||||||
|
distributivitySpec :: Spec
|
||||||
|
distributivitySpec =
|
||||||
|
describe "choice" $ do
|
||||||
|
it "distributes endpoints through static paths" $ do
|
||||||
|
endpoint `shouldHaveSameStructureAs` endpointRef
|
||||||
|
it "distributes nested routes through static paths" $ do
|
||||||
|
static `shouldHaveSameStructureAs` staticRef
|
||||||
|
it "distributes nested routes through dynamic paths" $ do
|
||||||
|
dynamic `shouldHaveSameStructureAs` dynamicRef
|
||||||
|
it "properly reorders permuted static paths" $ do
|
||||||
|
permute `shouldHaveSameStructureAs` permuteRef
|
||||||
|
it "properly reorders permuted static paths in the presence of Raw in end" $ do
|
||||||
|
permuteRawEnd `shouldHaveSameStructureAs` permuteRawEndRef
|
||||||
|
it "properly reorders permuted static paths in the presence of Raw in beginning" $ do
|
||||||
|
permuteRawBegin `shouldHaveSameStructureAs` permuteRawBeginRef
|
||||||
|
it "properly reorders permuted static paths in the presence of Raw in middle" $ do
|
||||||
|
permuteRawMiddle `shouldHaveSameStructureAs` permuteRawMiddleRef
|
||||||
|
it "properly reorders permuted static paths in the presence of a root endpoint in end" $ do
|
||||||
|
permuteEndEnd `shouldHaveSameStructureAs` permuteEndRef
|
||||||
|
it "properly reorders permuted static paths in the presence of a root endpoint in beginning" $ do
|
||||||
|
permuteEndBegin `shouldHaveSameStructureAs` permuteEndRef
|
||||||
|
it "properly reorders permuted static paths in the presence of a root endpoint in middle" $ do
|
||||||
|
permuteEndMiddle `shouldHaveSameStructureAs` permuteEndRef
|
||||||
|
it "properly handles mixing static paths at different levels" $ do
|
||||||
|
level `shouldHaveSameStructureAs` levelRef
|
||||||
|
|
||||||
|
shouldHaveSameStructureAs ::
|
||||||
|
(HasServer api1 '[], HasServer api2 '[]) => Proxy api1 -> Proxy api2 -> Expectation
|
||||||
|
shouldHaveSameStructureAs p1 p2 =
|
||||||
|
unless (sameStructure (makeTrivialRouter p1) (makeTrivialRouter p2)) $
|
||||||
|
expectationFailure ("expected:\n" ++ unpack (layout p2) ++ "\nbut got:\n" ++ unpack (layout p1))
|
||||||
|
|
||||||
|
makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router
|
||||||
|
makeTrivialRouter p = route p EmptyContext d
|
||||||
|
where
|
||||||
|
d = Delayed r r r r (\ _ _ _ -> FailFatal err501)
|
||||||
|
r = return (Route ())
|
||||||
|
|
||||||
|
type End = Get '[JSON] ()
|
||||||
|
|
||||||
|
-- The latter version looks more efficient,
|
||||||
|
-- but the former should be compiled to the
|
||||||
|
-- same layout:
|
||||||
|
|
||||||
|
type Endpoint = "a" :> End :<|> "a" :> End
|
||||||
|
type EndpointRef = "a" :> (End :<|> End)
|
||||||
|
|
||||||
|
endpoint :: Proxy Endpoint
|
||||||
|
endpoint = Proxy
|
||||||
|
|
||||||
|
endpointRef :: Proxy EndpointRef
|
||||||
|
endpointRef = Proxy
|
||||||
|
|
||||||
|
-- Again, the latter version looks more efficient,
|
||||||
|
-- but the former should be compiled to the same
|
||||||
|
-- layout:
|
||||||
|
|
||||||
|
type Static = "a" :> "b" :> End :<|> "a" :> "c" :> End
|
||||||
|
type StaticRef = "a" :> ("b" :> End :<|> "c" :> End)
|
||||||
|
|
||||||
|
static :: Proxy Static
|
||||||
|
static = Proxy
|
||||||
|
|
||||||
|
staticRef :: Proxy StaticRef
|
||||||
|
staticRef = Proxy
|
||||||
|
|
||||||
|
-- Even for dynamic path components, we expect the
|
||||||
|
-- router to simplify the layout, because captures
|
||||||
|
-- are delayed and only actually performed once
|
||||||
|
-- reaching an endpoint. So the former version and
|
||||||
|
-- the latter should be compiled to the same router
|
||||||
|
-- structure:
|
||||||
|
|
||||||
|
type Dynamic =
|
||||||
|
"a" :> Capture "foo" Int :> "b" :> End
|
||||||
|
:<|> "a" :> Capture "bar" Bool :> "c" :> End
|
||||||
|
:<|> "a" :> Capture "baz" Char :> "d" :> End
|
||||||
|
|
||||||
|
type DynamicRef =
|
||||||
|
"a" :> Capture "anything" () :>
|
||||||
|
("b" :> End :<|> "c" :> End :<|> "d" :> End)
|
||||||
|
|
||||||
|
dynamic :: Proxy Dynamic
|
||||||
|
dynamic = Proxy
|
||||||
|
|
||||||
|
dynamicRef :: Proxy DynamicRef
|
||||||
|
dynamicRef = Proxy
|
||||||
|
|
||||||
|
-- A more complicated example of static route reordering.
|
||||||
|
-- All the permuted paths should be correctly grouped,
|
||||||
|
-- so both 'Permute' and 'PermuteRef' should compile to
|
||||||
|
-- the same layout:
|
||||||
|
|
||||||
|
type Permute =
|
||||||
|
"a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
|
||||||
|
type PermuteRef =
|
||||||
|
"a" :> ( "b" :> "c" :> End
|
||||||
|
:<|> "c" :> "b" :> End
|
||||||
|
)
|
||||||
|
:<|> "b" :> ( "a" :> "c" :> End
|
||||||
|
:<|> "c" :> "a" :> End
|
||||||
|
)
|
||||||
|
:<|> "c" :> ( "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "a" :> End
|
||||||
|
)
|
||||||
|
|
||||||
|
permute :: Proxy Permute
|
||||||
|
permute = Proxy
|
||||||
|
|
||||||
|
permuteRef :: Proxy PermuteRef
|
||||||
|
permuteRef = Proxy
|
||||||
|
|
||||||
|
-- Adding a 'Raw' in one of the ends should have minimal
|
||||||
|
-- effect on the grouping.
|
||||||
|
|
||||||
|
type PermuteRawEnd =
|
||||||
|
"a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
:<|> Raw
|
||||||
|
|
||||||
|
type PermuteRawEndRef = PermuteRef :<|> Raw
|
||||||
|
|
||||||
|
type PermuteRawBegin =
|
||||||
|
Raw
|
||||||
|
:<|> "a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
|
||||||
|
type PermuteRawBeginRef = Raw :<|> PermuteRef
|
||||||
|
|
||||||
|
permuteRawBegin :: Proxy PermuteRawBegin
|
||||||
|
permuteRawBegin = Proxy
|
||||||
|
|
||||||
|
permuteRawBeginRef :: Proxy PermuteRawBeginRef
|
||||||
|
permuteRawBeginRef = Proxy
|
||||||
|
|
||||||
|
permuteRawEnd :: Proxy PermuteRawEnd
|
||||||
|
permuteRawEnd = Proxy
|
||||||
|
|
||||||
|
permuteRawEndRef :: Proxy PermuteRawEndRef
|
||||||
|
permuteRawEndRef = Proxy
|
||||||
|
|
||||||
|
-- Adding a 'Raw' in the middle will disrupt grouping,
|
||||||
|
-- because we commute things past a 'Raw'. But the two
|
||||||
|
-- halves should still be grouped.
|
||||||
|
|
||||||
|
type PermuteRawMiddle =
|
||||||
|
"a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> Raw
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
|
||||||
|
type PermuteRawMiddleRef =
|
||||||
|
"a" :> ( "b" :> "c" :> End
|
||||||
|
:<|> "c" :> "b" :> End
|
||||||
|
)
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> Raw
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> ( "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "a" :> End
|
||||||
|
)
|
||||||
|
|
||||||
|
permuteRawMiddle :: Proxy PermuteRawMiddle
|
||||||
|
permuteRawMiddle = Proxy
|
||||||
|
|
||||||
|
permuteRawMiddleRef :: Proxy PermuteRawMiddleRef
|
||||||
|
permuteRawMiddleRef = Proxy
|
||||||
|
|
||||||
|
-- Adding an endpoint at the top-level in various places
|
||||||
|
-- is also somewhat critical for grouping, but it should
|
||||||
|
-- not disrupt grouping at all, even if it is placed in
|
||||||
|
-- the middle.
|
||||||
|
|
||||||
|
type PermuteEndEnd =
|
||||||
|
"a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
:<|> End
|
||||||
|
|
||||||
|
type PermuteEndBegin =
|
||||||
|
End
|
||||||
|
:<|> "a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
|
||||||
|
type PermuteEndMiddle =
|
||||||
|
"a" :> "b" :> "c" :> End
|
||||||
|
:<|> "b" :> "a" :> "c" :> End
|
||||||
|
:<|> "a" :> "c" :> "b" :> End
|
||||||
|
:<|> End
|
||||||
|
:<|> "c" :> "a" :> "b" :> End
|
||||||
|
:<|> "b" :> "c" :> "a" :> End
|
||||||
|
:<|> "c" :> "b" :> "a" :> End
|
||||||
|
|
||||||
|
type PermuteEndRef = PermuteRef :<|> End
|
||||||
|
|
||||||
|
permuteEndEnd :: Proxy PermuteEndEnd
|
||||||
|
permuteEndEnd = Proxy
|
||||||
|
|
||||||
|
permuteEndBegin :: Proxy PermuteEndBegin
|
||||||
|
permuteEndBegin = Proxy
|
||||||
|
|
||||||
|
permuteEndMiddle :: Proxy PermuteEndMiddle
|
||||||
|
permuteEndMiddle = Proxy
|
||||||
|
|
||||||
|
permuteEndRef :: Proxy PermuteEndRef
|
||||||
|
permuteEndRef = Proxy
|
||||||
|
|
||||||
|
-- An API with routes on different nesting levels that
|
||||||
|
-- is composed out of different fragments should still
|
||||||
|
-- be reordered correctly.
|
||||||
|
|
||||||
|
type LevelFragment1 =
|
||||||
|
"a" :> "b" :> End
|
||||||
|
:<|> "a" :> End
|
||||||
|
|
||||||
|
type LevelFragment2 =
|
||||||
|
"b" :> End
|
||||||
|
:<|> "a" :> "c" :> End
|
||||||
|
:<|> End
|
||||||
|
|
||||||
|
type Level = LevelFragment1 :<|> LevelFragment2
|
||||||
|
|
||||||
|
type LevelRef =
|
||||||
|
"a" :> ("b" :> End :<|> "c" :> End :<|> End)
|
||||||
|
:<|> "b" :> End
|
||||||
|
:<|> End
|
||||||
|
|
||||||
|
level :: Proxy Level
|
||||||
|
level = Proxy
|
||||||
|
|
||||||
|
levelRef :: Proxy LevelRef
|
||||||
|
levelRef = Proxy
|
|
@ -13,9 +13,6 @@
|
||||||
|
|
||||||
module Servant.ServerSpec where
|
module Servant.ServerSpec where
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
#endif
|
|
||||||
import Control.Monad (forM_, when, unless)
|
import Control.Monad (forM_, when, unless)
|
||||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||||
|
@ -36,8 +33,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
||||||
parseQuery)
|
parseQuery)
|
||||||
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
||||||
queryString, rawQueryString,
|
queryString, rawQueryString,
|
||||||
responseBuilder, responseLBS)
|
responseLBS)
|
||||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
|
||||||
import Network.Wai.Test (defaultRequest, request,
|
import Network.Wai.Test (defaultRequest, request,
|
||||||
runSession, simpleBody,
|
runSession, simpleBody,
|
||||||
simpleHeaders, simpleStatus)
|
simpleHeaders, simpleStatus)
|
||||||
|
@ -66,11 +62,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec
|
||||||
import Servant.Server.Experimental.Auth
|
import Servant.Server.Experimental.Auth
|
||||||
(AuthHandler, AuthServerData,
|
(AuthHandler, AuthServerData,
|
||||||
mkAuthHandler)
|
mkAuthHandler)
|
||||||
import Servant.Server.Internal.RoutingApplication
|
|
||||||
(toApplication, RouteResult(..))
|
|
||||||
import Servant.Server.Internal.Router
|
|
||||||
(tweakResponse, runRouter,
|
|
||||||
Router, Router'(LeafRouter))
|
|
||||||
import Servant.Server.Internal.Context
|
import Servant.Server.Internal.Context
|
||||||
(NamedContext(..))
|
(NamedContext(..))
|
||||||
|
|
||||||
|
@ -94,7 +85,6 @@ spec = do
|
||||||
rawSpec
|
rawSpec
|
||||||
alternativeSpec
|
alternativeSpec
|
||||||
responseHeadersSpec
|
responseHeadersSpec
|
||||||
routerSpec
|
|
||||||
miscCombinatorSpec
|
miscCombinatorSpec
|
||||||
basicAuthSpec
|
basicAuthSpec
|
||||||
genAuthSpec
|
genAuthSpec
|
||||||
|
@ -482,28 +472,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
|
||||||
THW.request method "" [(hAccept, "crazy/mime")] ""
|
THW.request method "" [(hAccept, "crazy/mime")] ""
|
||||||
`shouldRespondWith` 406
|
`shouldRespondWith` 406
|
||||||
|
|
||||||
-- }}}
|
|
||||||
------------------------------------------------------------------------------
|
|
||||||
-- * routerSpec {{{
|
|
||||||
------------------------------------------------------------------------------
|
|
||||||
routerSpec :: Spec
|
|
||||||
routerSpec = do
|
|
||||||
describe "Servant.Server.Internal.Router" $ do
|
|
||||||
let app' :: Application
|
|
||||||
app' = toApplication $ runRouter router'
|
|
||||||
|
|
||||||
router', router :: Router
|
|
||||||
router' = tweakResponse (twk <$>) router
|
|
||||||
router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
|
|
||||||
|
|
||||||
twk :: Response -> Response
|
|
||||||
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
|
|
||||||
twk b = b
|
|
||||||
|
|
||||||
describe "tweakResponse" . with (return app') $ do
|
|
||||||
it "calls f on route result" $ do
|
|
||||||
get "" `shouldRespondWith` 202
|
|
||||||
|
|
||||||
-- }}}
|
-- }}}
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- * miscCombinatorSpec {{{
|
-- * miscCombinatorSpec {{{
|
||||||
|
|
Loading…
Reference in a new issue