servant/servant-client/test/Servant/SuccessSpec.hs
Gaël Deest 658217b021 Use toEncodedUrlPiece directly when encoding captures
Current implementation of captures uses the `toUrlPiece` method from the
`ToHttpApiData` typeclass, and encodes the resulting `Text` using `toEncodedUrlPiece`
when appending to the request path.

The problem with this approach is that the instance for `Text` percent-encodes
characters that are perfectly valid in URLs, such as `*`.

This patch makes direct use of `toEncodedUrlPiece`, which lets users implement
encoding according to their needs.

Closes #1511
2022-03-21 17:29:23 +01:00

207 lines
9.5 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -freduction-depth=100 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Servant.SuccessSpec (spec) where
import Prelude ()
import Prelude.Compat
import Control.Arrow
((+++), left)
import Control.Concurrent.STM
(atomically)
import Control.Concurrent.STM.TVar
(newTVar, readTVar)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
(forM_, toList)
import Data.Maybe
(listToMaybe)
import Data.Monoid ()
import Data.Text
(Text)
import Data.Text.Encoding
(encodeUtf8)
import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Types as HTTP
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck
import Servant.API
(NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
import Servant.Client
import qualified Servant.Client.Core.Request as Req
import Servant.ClientTestUtils
import Servant.Test.ComprehensiveAPI
-- This declaration simply checks that all instances are in place.
_ = client comprehensiveAPIWithoutStreaming
spec :: Spec
spec = describe "Servant.SuccessSpec" $ do
successSpec
successSpec :: Spec
successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
describe "Servant.API.Get" $ do
it "get root endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getRoot baseUrl `shouldReturn` Right carol
it "get simple endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
it "get redirection endpoint" $ \(_, baseUrl) -> do
left show <$> runClient getGet307 baseUrl `shouldReturn` Right "redirecting"
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [Person "Paula" 0, Person "Peta" 1]
left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
it "Servant.API FailureResponse" $ \(_, baseUrl) -> do
left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
Left (FailureResponse req _) <- runClient (getQueryParam (Just "bob")) baseUrl
Req.requestPath req `shouldBe` (baseUrl, "/param")
toList (Req.requestQueryString req) `shouldBe` [("name", Just "bob")]
Req.requestMethod req `shouldBe` HTTP.methodGet
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl
responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do
let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128]
apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet
(show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload)
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
it "Servant.API.Fragment" $ \(_, baseUrl) -> do
left id <$> runClient getFragment baseUrl `shouldReturn` Right alice
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
case res of
Left e -> assertFailure $ show e
Right r -> do
responseStatusCode r `shouldBe` HTTP.status200
responseBody r `shouldBe` "rawSuccess"
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
res <- runClient (getRawFailure HTTP.methodGet) baseUrl
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left (FailureResponse _ r) -> do
responseStatusCode r `shouldBe` HTTP.status400
responseBody r `shouldBe` "rawFailure"
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
it "Returns headers appropriately" $ \(_, baseUrl) -> do
res <- runClient getRespHeaders baseUrl
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do
res <- runClient getUVerbRespHeaders baseUrl
case res of
Left e -> assertFailure $ show e
Right val -> case matchUnion val of
Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
-> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
Nothing -> assertFailure "unexpected alternative of union"
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings
cj <- atomically . newTVar $ C.createCookieJar []
_ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
C.cookie_name <$> cookie `shouldBe` Just "testcookie"
C.cookie_value <$> cookie `shouldBe` Just "test"
it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings
-- In proper situation, extra headers should probably be visible in API type.
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
case res of
Left e ->
assertFailure $ show e
Right r ->
("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True
modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
return $
result === Right (cap, num, flag, body)
context "With a route that can either return success or redirect" $ do
it "Redirects when appropriate" $ \(_, baseUrl) -> do
eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
case eitherResponse of
Left clientError -> fail $ show clientError
Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")
it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl
case eitherResponse of
Left clientError -> fail $ show clientError
Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)
context "with a route that uses uverb but only has a single response" $
it "returns the expected response" $ \(_, baseUrl) -> do
eitherResponse <- runClient (uverbGetCreated) baseUrl
case eitherResponse of
Left clientError -> fail $ show clientError
Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)
it "encodes URL pieces following ToHttpApiData instance" $ \(_, baseUrl) -> do
let textOrig = "*"
eitherResponse <- runClient (captureVerbatim $ Verbatim $ encodeUtf8 textOrig) baseUrl
case eitherResponse of
Left clientError -> fail $ show clientError
Right textBack -> textBack `shouldBe` textOrig