Avoid using SOP constructors directly (#1434)
This is a followup to #1420. It uses `respond` and `matchUnion`, with the help of some type annotations, instead of the NS constructors from SOP.
This commit is contained in:
parent
21682f6b72
commit
19ec395e66
2 changed files with 8 additions and 11 deletions
|
@ -32,7 +32,6 @@ import Data.Foldable
|
|||
import Data.Maybe
|
||||
(listToMaybe)
|
||||
import Data.Monoid ()
|
||||
import Data.SOP (NS (..), I (..))
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Network.HTTP.Client as C
|
||||
|
@ -43,11 +42,9 @@ import Test.HUnit
|
|||
import Test.QuickCheck
|
||||
|
||||
import Servant.API
|
||||
(NoContent (NoContent), WithStatus (WithStatus), getHeaders)
|
||||
(NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Request as Req
|
||||
import Servant.Client.Internal.HttpClient
|
||||
(defaultMakeClientRequest)
|
||||
import Servant.ClientTestUtils
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
|
||||
|
@ -134,9 +131,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
res <- runClient getUVerbRespHeaders baseUrl
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right (Z (I (WithStatus val))) ->
|
||||
getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
||||
Right (S _) -> assertFailure "expected first alternative of union"
|
||||
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
|
||||
|
|
|
@ -7,6 +7,7 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -freduction-depth=100 #-}
|
||||
|
||||
module Servant.ServerSpec where
|
||||
|
@ -28,8 +29,6 @@ import Data.Maybe
|
|||
(fromMaybe)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.SOP
|
||||
(I (..), NS (..))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.String.Conversions
|
||||
|
@ -699,8 +698,8 @@ type UVerbResponseHeadersApi =
|
|||
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
|
||||
|
||||
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
|
||||
uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
|
||||
uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
|
||||
uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
|
||||
uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
|
||||
|
||||
uverbResponseHeadersSpec :: Spec
|
||||
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do
|
||||
|
|
Loading…
Reference in a new issue