eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Avoid using SOP constructors directly (#1434)

Browse source 
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:
Paolo Capriotti 2021-07-13 17:10:30 +02:00 committed by GitHub
parent 21682f6b72
commit 19ec395e66
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 8 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
servant-client/test/Servant/SuccessSpec.hs
View file

@ -32,7 +32,6 @@ import Data.Foldable
import Data.Maybe import Data.Maybe
(listToMaybe) (listToMaybe)
import Data.Monoid () import Data.Monoid ()
import Data.SOP (NS (..), I (..))
import Data.Text import Data.Text
(Text) (Text)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
@ -43,11 +42,9 @@ import Test.HUnit
import Test.QuickCheck import Test.QuickCheck
import Servant.API import Servant.API
(NoContent (NoContent), WithStatus (WithStatus), getHeaders) (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
import Servant.Client import Servant.Client
import qualified Servant.Client.Core.Request as Req import qualified Servant.Client.Core.Request as Req
import Servant.Client.Internal.HttpClient
(defaultMakeClientRequest)
import Servant.ClientTestUtils import Servant.ClientTestUtils
import Servant.Test.ComprehensiveAPI import Servant.Test.ComprehensiveAPI
@ -134,9 +131,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
res <- runClient getUVerbRespHeaders baseUrl res <- runClient getUVerbRespHeaders baseUrl
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (Z (I (WithStatus val))) -> Right val -> case matchUnion val of
getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
Right (S _) -> assertFailure "expected first alternative of union" -> 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 it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
mgr <- C.newManager C.defaultManagerSettings mgr <- C.newManager C.defaultManagerSettings

7
servant-server/test/Servant/ServerSpec.hs
View file

@ -7,6 +7,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -freduction-depth=100 #-}
module Servant.ServerSpec where module Servant.ServerSpec where
@ -28,8 +29,6 @@ import Data.Maybe
(fromMaybe) (fromMaybe)
import Data.Proxy import Data.Proxy
(Proxy (Proxy)) (Proxy (Proxy))
import Data.SOP
(I (..), NS (..))
import Data.String import Data.String
(fromString) (fromString)
import Data.String.Conversions import Data.String.Conversions
@ -699,8 +698,8 @@ type UVerbResponseHeadersApi =
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo" uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar" uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
uverbResponseHeadersSpec :: Spec uverbResponseHeadersSpec :: Spec
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do