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:
Andres Loeh
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
|
||||
-----
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ module Servant.Server
|
|||
HasServer(..)
|
||||
, Server
|
||||
|
||||
-- * Debugging the server layout
|
||||
, layout
|
||||
, layoutWithContext
|
||||
|
||||
-- * Enter
|
||||
-- $enterDoc
|
||||
|
||||
|
|
@ -93,6 +97,7 @@ module Servant.Server
|
|||
) where
|
||||
|
||||
import Data.Proxy (Proxy)
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Application)
|
||||
import Servant.Server.Internal
|
||||
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)
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -26,11 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)
|
|||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
||||
symbolVal)
|
||||
|
|
@ -38,7 +36,7 @@ import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
|||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, Request, Response,
|
||||
httpVersion, isSecure,
|
||||
lazyRequestBody, pathInfo,
|
||||
lazyRequestBody,
|
||||
rawQueryString, remoteHost,
|
||||
requestHeaders, requestMethod,
|
||||
responseLBS, vault)
|
||||
|
|
@ -161,26 +159,23 @@ methodRouter :: (AllCTRender ctypes a)
|
|||
=> Method -> Proxy ctypes -> Status
|
||||
-> Delayed (ExceptT ServantErr IO a)
|
||||
-> Router
|
||||
methodRouter method proxy status action = LeafRouter route'
|
||||
methodRouter method proxy status action = leafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request =
|
||||
route' request respond =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
-> Delayed (ExceptT ServantErr IO (Headers h v))
|
||||
-> Router
|
||||
methodRouterHeaders method proxy status action = LeafRouter route'
|
||||
methodRouterHeaders method proxy status action = leafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request =
|
||||
route' request respond =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
|
|
@ -188,7 +183,6 @@ methodRouterHeaders method proxy status action = LeafRouter route'
|
|||
let headers = getHeaders output
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||
|
|
@ -359,7 +353,7 @@ instance HasServer Raw context where
|
|||
|
||||
type ServerT Raw m = Application
|
||||
|
||||
route Proxy _ rawApplication = LeafRouter $ \ request respond -> do
|
||||
route Proxy _ rawApplication = RawRouter $ \ request respond -> do
|
||||
r <- runDelayed rawApplication
|
||||
case r of
|
||||
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
|
||||
|
||||
route Proxy context subserver = StaticRouter $
|
||||
M.singleton (cs (symbolVal proxyPath))
|
||||
(route (Proxy :: Proxy sublayout) context subserver)
|
||||
route Proxy context subserver =
|
||||
pathRouter
|
||||
(cs (symbolVal proxyPath))
|
||||
(route (Proxy :: Proxy sublayout) context subserver)
|
||||
where proxyPath = Proxy :: Proxy path
|
||||
|
||||
instance HasServer api context => HasServer (RemoteHost :> api) context where
|
||||
|
|
@ -465,12 +460,6 @@ instance ( KnownSymbol realm
|
|||
|
||||
-- * helpers
|
||||
|
||||
pathIsEmpty :: Request -> Bool
|
||||
pathIsEmpty = go . pathInfo
|
||||
where go [] = True
|
||||
go [""] = True
|
||||
go _ = False
|
||||
|
||||
ct_wildcard :: B.ByteString
|
||||
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.Server.Internal.Router where
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Network.Wai (Request, Response, pathInfo)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
|
@ -13,36 +16,46 @@ type Router = Router' RoutingApplication
|
|||
|
||||
-- | Internal representation of a router.
|
||||
data Router' a =
|
||||
WithRequest (Request -> Router)
|
||||
WithRequest (Request -> Router' a)
|
||||
-- ^ current request is passed to the router
|
||||
| StaticRouter (Map Text Router)
|
||||
-- ^ first path component used for lookup and removed afterwards
|
||||
| DynamicRouter (Text -> Router)
|
||||
-- ^ first path component used for lookup and removed afterwards
|
||||
| LeafRouter a
|
||||
-- ^ to be used for routes that match an empty path
|
||||
| Choice Router Router
|
||||
| StaticRouter (Map Text (Router' a)) [a]
|
||||
-- ^ the map contains routers for subpaths (first path component used
|
||||
-- for lookup and removed afterwards), the list contains handlers
|
||||
-- for the empty path, to be tried in order
|
||||
| DynamicRouter (Text -> Router' a)
|
||||
-- ^ first path component passed to the function and removed afterwards
|
||||
| RawRouter a
|
||||
-- ^ to be used for routes we do not know anything about
|
||||
| Choice (Router' a) (Router' a)
|
||||
-- ^ left-biased choice between two routers
|
||||
deriving Functor
|
||||
|
||||
-- | 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))
|
||||
-- | Smart constructor for a single static path component.
|
||||
pathRouter :: Text -> Router' a -> Router' a
|
||||
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.
|
||||
-- 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 'WithRequest' routers can be joined by passing them
|
||||
-- the same request and joining their codomains.
|
||||
-- * A 'WithRequest' router can be joined with anything else by
|
||||
-- passing the same request to both but ignoring it in the
|
||||
-- component that does not need it.
|
||||
-- * Choice nodes can be reordered.
|
||||
--
|
||||
choice :: Router -> Router -> Router
|
||||
choice (StaticRouter table1) (StaticRouter table2) =
|
||||
StaticRouter (M.unionWith choice table1 table2)
|
||||
choice (StaticRouter table1 ls1) (StaticRouter table2 ls2) =
|
||||
StaticRouter (M.unionWith choice table1 table2) (ls1 ++ ls2)
|
||||
choice (DynamicRouter fun1) (DynamicRouter fun2) =
|
||||
DynamicRouter (\ first -> choice (fun1 first) (fun2 first))
|
||||
choice (WithRequest router1) (WithRequest router2) =
|
||||
|
|
@ -51,39 +64,136 @@ choice (WithRequest router1) router2 =
|
|||
WithRequest (\ request -> choice (router1 request) router2)
|
||||
choice router1 (WithRequest router2) =
|
||||
WithRequest (\ request -> choice router1 (router2 request))
|
||||
choice router1 (Choice router2 router3) = Choice (choice router1 router2) router3
|
||||
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.
|
||||
runRouter :: Router -> RoutingApplication
|
||||
runRouter (WithRequest router) request respond =
|
||||
runRouter (router request) request respond
|
||||
runRouter (StaticRouter table) request respond =
|
||||
runRouter (StaticRouter table ls) request respond =
|
||||
case pathInfo request of
|
||||
first : rest
|
||||
| Just router <- M.lookup first table
|
||||
[] -> runChoice ls request respond
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> runChoice ls request respond
|
||||
first : rest | Just router <- M.lookup first table
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter router request' respond
|
||||
_ -> respond $ Fail err404
|
||||
runRouter (DynamicRouter fun) request respond =
|
||||
case pathInfo request of
|
||||
[] -> respond $ Fail err404
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> respond $ Fail err404
|
||||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter (fun first) request' respond
|
||||
_ -> respond $ Fail err404
|
||||
runRouter (LeafRouter app) request respond = app request respond
|
||||
runRouter (RawRouter app) request respond = app request respond
|
||||
runRouter (Choice r1 r2) request respond =
|
||||
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
|
||||
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
|
||||
runChoice [runRouter r1, runRouter r2] request respond
|
||||
|
||||
-- | 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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -35,31 +35,6 @@ toApplication ra request respond = ra request routingRespond
|
|||
routingRespond (FailFatal err) = respond $ responseServantErr err
|
||||
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
|
||||
-- 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
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative ((<$>))
|
||||
#endif
|
||||
import Control.Monad (forM_, when, unless)
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
|
|
@ -36,8 +33,7 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
|||
parseQuery)
|
||||
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseBuilder, responseLBS)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
responseLBS)
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
|
|
@ -66,11 +62,6 @@ import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthChec
|
|||
import Servant.Server.Experimental.Auth
|
||||
(AuthHandler, AuthServerData,
|
||||
mkAuthHandler)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
(tweakResponse, runRouter,
|
||||
Router, Router'(LeafRouter))
|
||||
import Servant.Server.Internal.Context
|
||||
(NamedContext(..))
|
||||
|
||||
|
|
@ -94,7 +85,6 @@ spec = do
|
|||
rawSpec
|
||||
alternativeSpec
|
||||
responseHeadersSpec
|
||||
routerSpec
|
||||
miscCombinatorSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
|
|
@ -482,28 +472,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
|
|||
THW.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`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 {{{
|
||||
|
|
|
|||
Loading…
Reference in a new issue