eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Improvements and visualization of router structure.

Browse Source 
* 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 2016-04-07 13:45:15 +02:00
parent ba57d20008
commit 8c778825c7
7 changed files with 527 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
servant-server/CHANGELOG.md
View File

@ -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
-----

72
servant-server/src/Servant/Server.hs
View File

@ -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

31
servant-server/src/Servant/Server/Internal.hs
View File

@ -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

170
servant-server/src/Servant/Server/Internal/Router.hs
View File

@ -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.
--

25
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View File

@ -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
View 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

34
servant-server/test/Servant/ServerSpec.hs
View File

@ -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 {{{