servant/servant-server/test/Servant/Server/RouterSpec.hs

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

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

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