Skip to content

Commit 19ec395

Browse files
authored
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.
1 parent 21682f6 commit 19ec395

File tree

2 files changed

+8
-11
lines changed

2 files changed

+8
-11
lines changed

servant-client/test/Servant/SuccessSpec.hs

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ import Data.Foldable
3232
import Data.Maybe
3333
(listToMaybe)
3434
import Data.Monoid ()
35-
import Data.SOP (NS (..), I (..))
3635
import Data.Text
3736
(Text)
3837
import qualified Network.HTTP.Client as C
@@ -43,11 +42,9 @@ import Test.HUnit
4342
import Test.QuickCheck
4443

4544
import Servant.API
46-
(NoContent (NoContent), WithStatus (WithStatus), getHeaders)
45+
(NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..))
4746
import Servant.Client
4847
import qualified Servant.Client.Core.Request as Req
49-
import Servant.Client.Internal.HttpClient
50-
(defaultMakeClientRequest)
5148
import Servant.ClientTestUtils
5249
import Servant.Test.ComprehensiveAPI
5350

@@ -134,9 +131,10 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
134131
res <- runClient getUVerbRespHeaders baseUrl
135132
case res of
136133
Left e -> assertFailure $ show e
137-
Right (Z (I (WithStatus val))) ->
138-
getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
139-
Right (S _) -> assertFailure "expected first alternative of union"
134+
Right val -> case matchUnion val of
135+
Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool))
136+
-> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
137+
Nothing -> assertFailure "unexpected alternative of union"
140138

141139
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
142140
mgr <- C.newManager C.defaultManagerSettings

servant-server/test/Servant/ServerSpec.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,7 @@
77
{-# LANGUAGE ScopedTypeVariables #-}
88
{-# LANGUAGE TypeFamilies #-}
99
{-# LANGUAGE TypeOperators #-}
10+
{-# LANGUAGE TypeApplications #-}
1011
{-# OPTIONS_GHC -freduction-depth=100 #-}
1112

1213
module Servant.ServerSpec where
@@ -28,8 +29,6 @@ import Data.Maybe
2829
(fromMaybe)
2930
import Data.Proxy
3031
(Proxy (Proxy))
31-
import Data.SOP
32-
(I (..), NS (..))
3332
import Data.String
3433
(fromString)
3534
import Data.String.Conversions
@@ -699,8 +698,8 @@ type UVerbResponseHeadersApi =
699698
Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse
700699

701700
uverbResponseHeadersServer :: Server UVerbResponseHeadersApi
702-
uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"
703-
uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"
701+
uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String)
702+
uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String)
704703

705704
uverbResponseHeadersSpec :: Spec
706705
uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do

0 commit comments

Comments
 (0)