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
(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
servant-server/test/Servant/ServerSpec.hs
View File

@ -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