Spec for WithRoutingHeader API combinator

servant-server/servant-server.cabal

@@ -143,6 +143,7 @@ test-suite spec
     , base-compat
     , base64-bytestring
     , bytestring
+    , containers
     , http-types
     , mtl
     , resourcet

servant-server/test/Servant/ServerSpec.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -25,6 +26,8 @@ import qualified Data.ByteString                   as BS
 import qualified Data.ByteString.Base64            as Base64
 import           Data.Char
                  (toUpper)
+import           Data.Map
+                 (fromList, notMember)
 import           Data.Maybe
                  (fromMaybe)
 import           Data.Proxy
@@ -49,20 +52,21 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
+                 Delete, EmptyAPI, Fragment, Get, GetNoContent,
-                 Headers, HttpVersion, IsSecure (..), JSON, Lenient,
+                 HasStatus (StatusOf), Header, Headers, HttpVersion,
-                 NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
+                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
-                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
+                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
-                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
+                 QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
-                 UVerb, Union, Verb, WithStatus (..), addHeader)
+                 SourceIO, StdMethod (..), Stream, StreamGet, Strict, UVerb,
+                 Union, Verb, WithRoutingHeader, WithStatus (..), addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err401, err403, err404, respond, serve,
+                 emptyServer, err401, err403, err404, err500, respond, serve,
                  serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
-                 (Spec, context, describe, it, shouldBe, shouldContain)
+                 (Spec, context, describe, it, shouldBe, shouldContain, shouldSatisfy)
 import           Test.Hspec.Wai
                  (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
                  with, (<:>))
@@ -103,6 +107,7 @@ spec = do
   miscCombinatorSpec
   basicAuthSpec
   genAuthSpec
+  routedPathHeadersSpec
 
 ------------------------------------------------------------------------------
 -- * verbSpec {{{
@@ -842,6 +847,102 @@ genAuthSpec = do
         it "plays nice with subsequent Raw endpoints" $ do
           get "/foo" `shouldRespondWith` 418
 
+-- }}}
+------------------------------------------------------------------------------
+-- * Routed path response headers {{{
+------------------------------------------------------------------------------
+
+type RoutedPathApi = WithRoutingHeader :>
+  (    "content"   :> Get '[JSON] Person
+  :<|> "noContent" :> GetNoContent
+  :<|> "header"    :> Get '[JSON] (Headers '[Header "H" Int] Person)
+  :<|> "stream"    :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString)
+  :<|> "animal"    :> (    Capture "legs" Int :> Get '[JSON] Animal
+                      :<|> CaptureAll "legs" Int :> Get '[JSON] Animal
+                      :<|> Capture "name" String :> Get '[JSON] Animal
+                      )
+  ) :<|> "withoutHeader" :> Get '[JSON] Person
+
+routedPathApi :: Proxy RoutedPathApi
+routedPathApi = Proxy
+
+routedPathServer :: Server RoutedPathApi
+routedPathServer =
+  (    return alice
+  :<|> return NoContent
+  :<|> return (addHeader 5 alice)
+  :<|> return (S.source ["bytestring"])
+  :<|> ((     \case
+                2 -> return tweety
+                4 -> return jerry
+                _ -> throwError err500
+       ):<|>( \ legs -> case sum legs of
+                2 -> return tweety
+                4 -> return jerry
+                _ -> throwError err500
+       ):<|>( \case
+                "tweety" -> return tweety
+                "jerry" -> return jerry
+                "bob" -> return beholder
+                _ -> throwError err404
+       ))
+  ) :<|> return alice
+
+routedPathHeadersSpec :: Spec
+routedPathHeadersSpec = do
+  describe "Server routing header" $ do
+    with (return $ serve routedPathApi routedPathServer) $ do
+      it "returns the routed path on verbs" $ do
+        response <- THW.request methodGet "/content" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/content")]
+
+      it "returns the routed path on noContent verbs" $ do
+        response <- THW.request methodGet "/noContent" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/noContent")]
+
+      it "returns the routed path on streams" $ do
+        response <- THW.request methodGet "/stream" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/stream")]
+
+      it "plays nice with manually added headers" $ do
+        response <- THW.request methodGet "/header" [] ""
+        liftIO $ do
+          simpleHeaders response `shouldContain` [("Servant-Routed-Path", "/header")]
+          simpleHeaders response `shouldContain` [("H", "5")]
+
+      it "abstracts captured values" $ do
+        response <- THW.request methodGet "/animal/4" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::Int>")]
+
+      it "abstracts captured lists" $ do
+        response <- THW.request methodGet "/animal/1/1/0" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::[Int]>")]
+
+      it "supports backtracking on routing errors" $ do
+        response <- THW.request methodGet "/animal/jerry" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<name::[Char]>")]
+
+      it "returns the routed path on a failing route" $ do
+        response <- THW.request methodGet "/animal/0" [] ""
+        liftIO $ simpleHeaders response `shouldContain`
+          [("Servant-Routed-Path", "/animal/<legs::Int>")]
+
+      it "is missing when no route matches" $ do
+        response <- THW.request methodGet "/wrongPath" [] ""
+        liftIO $ simpleHeaders response `shouldSatisfy`
+          (notMember "Servant-Routed-Path") . fromList
+
+      it "is missing when WithRoutingHeader is missing" $ do
+        response <- THW.request methodGet "/withoutHeader" [] ""
+        liftIO $ simpleHeaders response `shouldSatisfy`
+          (notMember "Servant-Routed-Path") . fromList
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * UVerb {{{