servant/servant-server/test/Servant/Server/RouterSpec.hs
2022-03-23 14:30:45 +01:00

462 lines
13 KiB
Haskell

{-# 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
(Text, unpack)
import Data.Typeable
(typeRep)
import Network.HTTP.Types
(Status (..))
import Network.Wai
(responseBuilder)
import Network.Wai.Internal
(Response (ResponseBuilder))
import Servant.API
import Servant.Server
import Servant.Server.Internal
import Test.Hspec
import Test.Hspec.Wai
(get, shouldRespondWith, with)
spec :: Spec
spec = describe "Servant.Server.Internal.Router" $ do
routerSpec
distributivitySpec
serverLayoutSpec
routerSpec :: Spec
routerSpec = do
describe "tweakResponse" $ do
let app' :: Application
app' = toApplication $ runRouter (const err404) 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
with (return app') $ do
it "calls f on route result" $ do
get "" `shouldRespondWith` 202
describe "runRouter" $ do
let toApp :: Router () -> Application
toApp = toApplication . runRouter (const err404)
cap :: Router ()
cap = CaptureRouter [hint] $
let delayed = addCapture (emptyDelayed $ Route pure) (const $ delayedFail err400)
in leafRouter
$ \env req res ->
runAction delayed env req res
. const
$ Route success
hint :: CaptureHint
hint = CaptureHint "anything" $ typeRep (Proxy :: Proxy ())
router :: Router ()
router = leafRouter (\_ _ res -> res $ Route success)
`Choice` cap
success :: Response
success = responseBuilder (Status 200 "") [] ""
with (pure $ toApp router) $ do
it "capture failure returns a 400 response" $ do
get "/badcapture" `shouldRespondWith` 400
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 QueryParams" $ do
permuteQuery `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
serverLayoutSpec :: Spec
serverLayoutSpec =
describe "serverLayout" $ do
it "correctly represents the example API" $ do
exampleLayout `shouldHaveLayout` expectedExampleLayout
it "aggregates capture hints when different" $ do
captureDifferentTypes `shouldHaveLayout` expectedCaptureDifferentTypes
it "nubs capture hints when equal" $ do
captureSameType `shouldHaveLayout` expectedCaptureSameType
it "properly displays CaptureAll hints" $ do
captureAllLayout `shouldHaveLayout` expectedCaptureAllLayout
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))
shouldHaveLayout ::
(HasServer api '[]) => Proxy api -> Text -> Expectation
shouldHaveLayout p l =
unless (routerLayout (makeTrivialRouter p) == l) $
expectationFailure ("expected:\n" ++ unpack l ++ "\nbut got:\n" ++ unpack (layout p))
makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router ()
makeTrivialRouter p =
route p EmptyContext (emptyDelayed (FailFatal err501))
type End = Get '[JSON] NoContent
-- 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 "foo" Int :> "c" :> End
:<|> "a" :> Capture "foo" Int :> "d" :> End
type DynamicRef =
"a" :> Capture "foo" Int :>
("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 "QueryParam" should not affect structure
type PermuteQuery =
QueryParam "1" Int :> "a" :> "b" :> "c" :> End
:<|> QueryParam "2" Int :> "b" :> "a" :> "c" :> End
:<|> QueryParam "3" Int :> "a" :> "c" :> "b" :> End
:<|> QueryParam "4" Int :> "c" :> "a" :> "b" :> End
:<|> QueryParam "5" Int :> "b" :> "c" :> "a" :> End
:<|> QueryParam "6" Int :> "c" :> "b" :> "a" :> End
permuteQuery :: Proxy PermuteQuery
permuteQuery = 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
-- The example API for the 'layout' function.
-- Should get factorized by the 'choice' smart constructor.
type ExampleLayout =
"a" :> "d" :> Get '[JSON] NoContent
:<|> "b" :> Capture "x" Int :> Get '[JSON] Bool
:<|> "c" :> Put '[JSON] Bool
:<|> "a" :> "e" :> Get '[JSON] Int
:<|> "b" :> Capture "x" Int :> Put '[JSON] Bool
:<|> Raw
exampleLayout :: Proxy ExampleLayout
exampleLayout = Proxy
-- The expected representation of the example API layout
--
expectedExampleLayout :: Text
expectedExampleLayout =
"/\n\
\├─ a/\n\
\│ ├─ d/\n\
\│ │ └─•\n\
\│ └─ e/\n\
\│ └─•\n\
\├─ b/\n\
\│ └─ <x::Int>/\n\
\│ ├─•\n\
\│ ┆\n\
\│ └─•\n\
\├─ c/\n\
\│ └─•\n\
\\n\
\└─ <raw>\n"
-- A capture API with all capture types being the same
--
type CaptureSameType =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "foo" Int :> "c" :> End
:<|> "a" :> Capture "foo" Int :> "d" :> End
captureSameType :: Proxy CaptureSameType
captureSameType = Proxy
-- The expected representation of the CaptureSameType API layout.
--
expectedCaptureSameType :: Text
expectedCaptureSameType =
"/\n\
\└─ a/\n\
\ └─ <foo::Int>/\n\
\ ├─ b/\n\
\ │ └─•\n\
\ ├─ c/\n\
\ │ └─•\n\
\ └─ d/\n\
\ └─•\n"
-- A capture API capturing different types
--
type CaptureDifferentTypes =
"a" :> Capture "foo" Int :> "b" :> End
:<|> "a" :> Capture "bar" Bool :> "c" :> End
:<|> "a" :> Capture "baz" Char :> "d" :> End
captureDifferentTypes :: Proxy CaptureDifferentTypes
captureDifferentTypes = Proxy
-- The expected representation of the CaptureDifferentTypes API layout.
--
expectedCaptureDifferentTypes :: Text
expectedCaptureDifferentTypes =
"/\n\
\└─ a/\n\
\ └─ <foo::Int|bar::Bool|baz::Char>/\n\
\ ├─ b/\n\
\ │ └─•\n\
\ ├─ c/\n\
\ │ └─•\n\
\ └─ d/\n\
\ └─•\n"
-- An API with a CaptureAll part
type CaptureAllLayout = "a" :> CaptureAll "foos" Int :> End
captureAllLayout :: Proxy CaptureAllLayout
captureAllLayout = Proxy
-- The expected representation of the CaptureAllLayout API.
--
expectedCaptureAllLayout :: Text
expectedCaptureAllLayout =
"/\n\
\└─ a/\n\
\ └─ <foos::[Int]>/\n\
\ └─•\n"