28fe7a0 · typeable/servant

git.iko.soy/typeable/servant

Merge pull request #803 from haskell-servant/pr800

Factor out servant-client-core

commit28fe7a0d0fc006801ae03436053096f2438906e7 authorJulian Arni <jkarni@gmail.com> dateMon 18 Sep 2017, 13:51 (9 years ago) parent885808c 1a67d93

28 files changed+1290−984

compare with master

unifiedsplit

doc/tutorial/Client.lhs+4−4

@@ -128,15 +128,15 @@ That's it. Let's now write some code that uses our client functions.

128128``` haskell

129129queries :: ClientM (Position, HelloMessage, Email)

130130queries = do

131− pos <- position 10 10

132− message <- hello (Just "servant")

131+ pos <- position 10 10

132+ message <- hello (Just "servant")

133133 em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])

134134 return (pos, message, em)

135135

136136run :: IO ()

137137run = do

138− manager <- newManager defaultManagerSettings

139− res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))

138+ manager' <- newManager defaultManagerSettings

139+ res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 ""))

140140 case res of

141141 Left err -> putStrLn $ "Error: " ++ show err

142142 Right (pos, message, em) -> do

servant-client-core/CHANGELOG.mdnew file+6

@@ -0,0 +1,6 @@

1+# Revision history for servant-client-core

3+## 0.12 -- YYYY-mm-dd

5+* First version. Factored out of servant-client all the functionality that was

6+independent of the http-client backend.

servant-client-core/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Servant Contributors nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

servant-client-core/README.mdnew file+30

@@ -0,0 +1,30 @@

1+# servant-client-core

3+![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)

5+HTTP-client-agnostic client functions for servant APIs.

7+This library should mainly be of interest to backend- and combinator-writers.

9+## For backend-writers

10+

11+If you are creating a new backend, you'll need to:

12+

13+1. Define a `RunClient` instance for your datatype (call it `MyMonad`)

14+2. Define a `ClientLike` instance. This will look like:

15+

16+``` haskell

17+instance ClientLike (MyMonad a) (MyMonad a) where

18+ mkClient = id

19+```

20+

21+3. Re-export the module Servant.Client.Core.Reexport so that your end-users

22+ can be blissfully unaware of 'servant-client-core', and so each

23+ backend-package comes closer to the warm hearth of the drop-in-replacement

24+ equivalence class.

25+

26+## For combinator-writers

27+

28+You'll need to define a new `HasClient` instance for your combinator. There are

29+plenty of examples to guide you in the

30+[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module.

servant-client-core/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

servant-client-core/include/overlapping-compat.hnew file+8

@@ -0,0 +1,8 @@

1+#if __GLASGOW_HASKELL__ >= 710

2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}

3+#define OVERLAPPING_ {-# OVERLAPPING #-}

4+#else

5+{-# LANGUAGE OverlappingInstances #-}

6+#define OVERLAPPABLE_

7+#define OVERLAPPING_

8+#endif

servant-client-core/servant-client-core.cabalnew file+74

@@ -0,0 +1,74 @@

1+name: servant-client-core

2+version: 0.11

3+synopsis: Core functionality and class for client function generation for servant APIs

4+description:

5+ This library provides backend-agnostic generation of client functions. For

6+ more information, see the README.

7+license: BSD3

8+license-file: LICENSE

9+author: Servant Contributors

10+maintainer: haskell-servant-maintainers@googlegroups.com

11+homepage: http://haskell-servant.readthedocs.org/

12+bug-reports: http://github.com/haskell-servant/servant/issues

13+cabal-version: >=1.10

14+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors

15+category: Web

16+build-type: Simple

17+extra-source-files:

18+ include/*.h

19+ CHANGELOG.md

20+ README.md

21+source-repository head

22+ type: git

23+ location: http://github.com/haskell-servant/servant.git

24+

25+library

26+ exposed-modules:

27+ Servant.Client.Core

28+ Servant.Client.Core.Reexport

29+ Servant.Client.Core.Internal.Auth

30+ Servant.Client.Core.Internal.BaseUrl

31+ Servant.Client.Core.Internal.BasicAuth

32+ Servant.Client.Core.Internal.Generic

33+ Servant.Client.Core.Internal.HasClient

34+ Servant.Client.Core.Internal.Request

35+ Servant.Client.Core.Internal.RunClient

36+ build-depends:

37+ base >= 4.7 && < 4.11

38+ , base-compat >= 0.9.1 && < 0.10

39+ , base64-bytestring >= 1.0.0.1 && < 1.1

40+ , bytestring >= 0.10 && < 0.11

41+ , containers >= 0.5 && < 0.6

42+ , exceptions >= 0.8 && < 0.9

43+ , generics-sop >= 0.1.0.0 && < 0.4

44+ , http-api-data >= 0.3.6 && < 0.4

45+ , http-media >= 0.6.2 && < 0.8

46+ , http-types >= 0.8.6 && < 0.10

47+ , mtl >= 2.1 && < 2.3

48+ , network-uri >= 2.6 && < 2.7

49+ , safe >= 0.3.9 && < 0.4

50+ , servant == 0.11.*

51+ , text >= 1.2 && < 1.3

52+ if !impl(ghc >= 8.0)

53+ build-depends:

54+ semigroups >=0.16.2.2 && <0.19

55+ hs-source-dirs: src

56+ default-language: Haskell2010

57+ ghc-options: -Wall

58+ include-dirs: include

59+

60+test-suite spec

61+ type: exitcode-stdio-1.0

62+ ghc-options: -Wall

63+ default-language: Haskell2010

64+ hs-source-dirs: test

65+ main-is: Spec.hs

66+ build-depends:

67+ base

68+ , base-compat

69+ , deepseq

70+ , servant-client-core

71+ , hspec == 2.*

72+ , QuickCheck >= 2.7 && < 2.11

73+ other-modules:

74+ Servant.Client.Core.Internal.BaseUrlSpec

servant-client-core/src/Servant/Client/Core.hsnew file+65

@@ -0,0 +1,65 @@

1+-- | This module provides backend-agnostic functionality for generating clients

2+-- from @servant@ APIs. By "backend," we mean something that concretely

3+-- executes the request, such as:

4+--

5+-- * The @http-client@ library

6+-- * The @haxl@ library

7+-- * GHCJS via FFI

8+--

9+-- etc.

10+--

11+-- Each backend is encapsulated in a monad that is an instance of the

12+-- 'RunClient' class.

13+--

14+-- This library is primarily of interest to backend-writers and

15+-- combinator-writers. For more information, see the README.md

16+module Servant.Client.Core

17+ (

18+ -- * Client generation

19+ clientIn

20+ , HasClient(..)

21+

22+ -- * Request

23+ , Request

24+ , RequestF(..)

25+ , defaultRequest

26+ , RequestBody(..)

27+

28+ -- * Authentication

29+ , mkAuthenticatedRequest

30+ , basicAuthReq

31+ , AuthenticatedRequest(..)

32+ , AuthClientData

33+

34+ -- * Generic Client

35+ , ClientLike(..)

36+ , genericMkClientL

37+ , genericMkClientP

38+ , ServantError(..)

39+ , EmptyClient(..)

40+

41+

42+ -- * Response

43+ , Response(..)

44+ , RunClient(..)

45+ , module Servant.Client.Core.Internal.BaseUrl

46+

47+ -- * Writing HasClient instances

48+ -- | These functions need not be re-exported by backend libraries.

49+ , addHeader

50+ , appendToQueryString

51+ , appendToPath

52+ , setRequestBodyLBS

53+ , setRequestBody

54+ ) where

55+import Servant.Client.Core.Internal.Auth

56+import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),

57+ InvalidBaseUrlException,

58+ Scheme (..),

59+ parseBaseUrl,

60+ showBaseUrl)

61+import Servant.Client.Core.Internal.BasicAuth

62+import Servant.Client.Core.Internal.HasClient

63+import Servant.Client.Core.Internal.Generic

64+import Servant.Client.Core.Internal.Request

65+import Servant.Client.Core.Internal.RunClient

servant-client/src/Servant/Client/Experimental/Auth.hs → servant-client-core/src/Servant/Client/Core/Internal/Auth.hsrenamed+10−14

@@ -1,16 +1,12 @@

1−{-# LANGUAGE OverloadedStrings #-}

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeFamilies #-}

23{-# LANGUAGE TypeSynonymInstances #-}

3−{-# LANGUAGE TypeFamilies #-}

55-- | Authentication for clients

7−module Servant.Client.Experimental.Auth (

8− AuthenticateReq(AuthenticateReq, unAuthReq)

9− , AuthClientData

10− , mkAuthenticateReq

11− ) where

7+module Servant.Client.Core.Internal.Auth where

128

13−import Servant.Common.Req (Req)

9+import Servant.Client.Core.Internal.Request (Request)

1410

1511-- | For a resource protected by authentication (e.g. AuthProtect), we need

1612-- to provide the client with some data used to add authentication data

@@ -24,13 +20,13 @@ type family AuthClientData a :: *

2420-- data to a request

2521--

2622-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

27−newtype AuthenticateReq a =

28− AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }

23+newtype AuthenticatedRequest a =

24+ AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) }

2925

3026-- | Handy helper to avoid wrapping datatypes in tuples everywhere.

3127--

3228-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE

33−mkAuthenticateReq :: AuthClientData a

34− -> (AuthClientData a -> Req -> Req)

35− -> AuthenticateReq a

36−mkAuthenticateReq val func = AuthenticateReq (val, func)

29+mkAuthenticatedRequest :: AuthClientData a

30+ -> (AuthClientData a -> Request -> Request)

31+ -> AuthenticatedRequest a

32+mkAuthenticatedRequest val func = AuthenticatedRequest (val, func)

servant-client/src/Servant/Common/BaseUrl.hs → servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hsrenamed+2−10

@@ -1,21 +1,13 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE ViewPatterns #-}

4−module Servant.Common.BaseUrl (

5− -- * types

6− BaseUrl (..)

7− , InvalidBaseUrlException

8− , Scheme (..)

9− -- * functions

10− , parseBaseUrl

11− , showBaseUrl

12−) where

4+module Servant.Client.Core.Internal.BaseUrl where

135

146import Control.Monad.Catch (Exception, MonadThrow, throwM)

157import Data.List

168import Data.Typeable

179import GHC.Generics

18−import Network.URI hiding (path)

10+import Network.URI hiding (path)

1911import Safe

2012import Text.Read

2113

servant-client-core/src/Servant/Client/Core/Internal/BasicAuth.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeFamilies #-}

3+{-# LANGUAGE TypeSynonymInstances #-}

5+-- | Basic Authentication for clients

7+module Servant.Client.Core.Internal.BasicAuth where

9+import Data.ByteString.Base64 (encode)

10+import Data.Monoid ((<>))

11+import Data.Text.Encoding (decodeUtf8)

12+import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))

13+import Servant.Client.Core.Internal.Request (Request, addHeader)

14+

15+-- | Authenticate a request using Basic Authentication

16+basicAuthReq :: BasicAuthData -> Request -> Request

17+basicAuthReq (BasicAuthData user pass) req =

18+ let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))

19+ in addHeader "Authorization" authText req

servant-client/src/Servant/Client/Generic.hs → servant-client-core/src/Servant/Client/Core/Internal/Generic.hsrenamed+1−9

@@ -10,15 +10,10 @@

1010

1111#include "overlapping-compat.h"

1212

13−module Servant.Client.Generic

14− ( ClientLike(..)

15− , genericMkClientL

16− , genericMkClientP

17− ) where

13+module Servant.Client.Core.Internal.Generic where

1814

1915import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)

2016import Servant.API ((:<|>)(..))

21−import Servant.Client (ClientM)

2217

2318-- | This class allows us to match client structure with client functions

2419-- produced with 'client' without explicit pattern-matching.

@@ -111,9 +106,6 @@ instance ClientLike client custom

111106 => ClientLike (a -> client) (a -> custom) where

112107 mkClient c = mkClient . c

113108

114−instance ClientLike (ClientM a) (ClientM a) where

115− mkClient = id

116−

117109-- | Match client structure with client functions, regarding left-nested API clients

118110-- as separate data structures.

119111class GClientLikeP client xs where

servant-client-core/src/Servant/Client/Core/Internal/HasClient.hsnew file+541

@@ -0,0 +1,541 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+

14+#include "overlapping-compat.h"

15+module Servant.Client.Core.Internal.HasClient where

16+

17+import Prelude ()

18+import Prelude.Compat

19+

20+import Data.Foldable (toList)

21+import Data.List (foldl')

22+import Data.Proxy (Proxy (Proxy))

23+import Data.Sequence (fromList)

24+import Data.String (fromString)

25+import Data.Text (pack)

26+import GHC.TypeLits (KnownSymbol, symbolVal)

27+import qualified Network.HTTP.Types as H

28+import Servant.API ((:<|>) ((:<|>)), (:>),

29+ AuthProtect, BasicAuth,

30+ BasicAuthData,

31+ BuildHeadersTo (..),

32+ Capture, CaptureAll,

33+ Description, EmptyAPI,

34+ Header, Headers (..),

35+ HttpVersion, IsSecure,

36+ MimeRender (mimeRender),

37+ MimeUnrender (mimeUnrender),

38+ NoContent (NoContent),

39+ QueryFlag, QueryParam,

40+ QueryParams, Raw,

41+ ReflectMethod (..),

42+ RemoteHost, ReqBody,

43+ Summary, ToHttpApiData,

44+ Vault, Verb,

45+ WithNamedContext,

46+ contentType,

47+ getHeadersHList,

48+ getResponse,

49+ toQueryParam,

50+ toUrlPiece)

51+import Servant.API.ContentTypes (contentTypes)

52+

53+import Servant.Client.Core.Internal.Auth

54+import Servant.Client.Core.Internal.BasicAuth

55+import Servant.Client.Core.Internal.Request

56+import Servant.Client.Core.Internal.RunClient

57+

58+-- * Accessing APIs as a Client

59+

60+-- | 'clientIn' allows you to produce operations to query an API from a client

61+-- within a 'RunClient' monad.

62+--

63+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

64+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

65+-- >

66+-- > myApi :: Proxy MyApi

67+-- > myApi = Proxy

68+-- >

69+-- > clientM :: Proxy ClientM

70+-- > clientM = Proxy

71+-- >

72+-- > getAllBooks :: ClientM [Book]

73+-- > postNewBook :: Book -> ClientM Book

74+-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM

75+clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api

76+clientIn p pm = clientWithRoute pm p defaultRequest

77+

78+

79+-- | This class lets us define how each API combinator influences the creation

80+-- of an HTTP request.

81+--

82+-- Unless you are writing a new backend for @servant-client-core@ or new

83+-- combinators that you want to support client-generation, you can ignore this

84+-- class.

85+class RunClient m => HasClient m api where

86+ type Client (m :: * -> *) (api :: *) :: *

87+ clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api

88+

89+

90+-- | A client querying function for @a ':<|>' b@ will actually hand you

91+-- one function for querying @a@ and another one for querying @b@,

92+-- stitching them together with ':<|>', which really is just like a pair.

93+--

94+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

95+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books

96+-- >

97+-- > myApi :: Proxy MyApi

98+-- > myApi = Proxy

99+-- >

100+-- > getAllBooks :: ClientM [Book]

101+-- > postNewBook :: Book -> ClientM Book

102+-- > (getAllBooks :<|> postNewBook) = client myApi

103+instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where

104+ type Client m (a :<|> b) = Client m a :<|> Client m b

105+ clientWithRoute pm Proxy req =

106+ clientWithRoute pm (Proxy :: Proxy a) req :<|>

107+ clientWithRoute pm (Proxy :: Proxy b) req

108+

109+-- | Singleton type representing a client for an empty API.

110+data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)

111+

112+-- | The client for 'EmptyAPI' is simply 'EmptyClient'.

113+--

114+-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books

115+-- > :<|> "nothing" :> EmptyAPI

116+-- >

117+-- > myApi :: Proxy MyApi

118+-- > myApi = Proxy

119+-- >

120+-- > getAllBooks :: ClientM [Book]

121+-- > (getAllBooks :<|> EmptyClient) = client myApi

122+instance RunClient m => HasClient m EmptyAPI where

123+ type Client m EmptyAPI = EmptyClient

124+ clientWithRoute _pm Proxy _ = EmptyClient

125+

126+-- | If you use a 'Capture' in one of your endpoints in your API,

127+-- the corresponding querying function will automatically take

128+-- an additional argument of the type specified by your 'Capture'.

129+-- That function will take care of inserting a textual representation

130+-- of this value at the right place in the request path.

131+--

132+-- You can control how values for this type are turned into

133+-- text by specifying a 'ToHttpApiData' instance for your type.

134+--

135+-- Example:

136+--

137+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

138+-- >

139+-- > myApi :: Proxy MyApi

140+-- > myApi = Proxy

141+-- >

142+-- > getBook :: Text -> ClientM Book

143+-- > getBook = client myApi

144+-- > -- then you can just use "getBook" to query that endpoint

145+instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)

146+ => HasClient m (Capture capture a :> api) where

147+

148+ type Client m (Capture capture a :> api) =

149+ a -> Client m api

150+

151+ clientWithRoute pm Proxy req val =

152+ clientWithRoute pm (Proxy :: Proxy api)

153+ (appendToPath p req)

154+

155+ where p = (toUrlPiece val)

156+

157+-- | If you use a 'CaptureAll' in one of your endpoints in your API,

158+-- the corresponding querying function will automatically take an

159+-- additional argument of a list of the type specified by your

160+-- 'CaptureAll'. That function will take care of inserting a textual

161+-- representation of this value at the right place in the request

162+-- path.

163+--

164+-- You can control how these values are turned into text by specifying

165+-- a 'ToHttpApiData' instance of your type.

166+--

167+-- Example:

168+--

169+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile

170+-- >

171+-- > myApi :: Proxy

172+-- > myApi = Proxy

173+--

174+-- > getSourceFile :: [Text] -> ClientM SourceFile

175+-- > getSourceFile = client myApi

176+-- > -- then you can use "getSourceFile" to query that endpoint

177+instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)

178+ => HasClient m (CaptureAll capture a :> sublayout) where

179+

180+ type Client m (CaptureAll capture a :> sublayout) =

181+ [a] -> Client m sublayout

182+

183+ clientWithRoute pm Proxy req vals =

184+ clientWithRoute pm (Proxy :: Proxy sublayout)

185+ (foldl' (flip appendToPath) req ps)

186+

187+ where ps = map (toUrlPiece) vals

188+

189+instance OVERLAPPABLE_

190+ -- Note [Non-Empty Content Types]

191+ ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

192+ ) => HasClient m (Verb method status cts' a) where

193+ type Client m (Verb method status cts' a) = m a

194+ clientWithRoute _pm Proxy req = do

195+ response <- runRequest req

196+ { requestAccept = fromList $ toList accept

197+ , requestMethod = method

198+ }

199+ response `decodedAs` (Proxy :: Proxy ct)

200+ where

201+ accept = contentTypes (Proxy :: Proxy ct)

202+ method = reflectMethod (Proxy :: Proxy method)

203+

204+instance OVERLAPPING_

205+ ( RunClient m, ReflectMethod method

206+ ) => HasClient m (Verb method status cts NoContent) where

207+ type Client m (Verb method status cts NoContent)

208+ = m NoContent

209+ clientWithRoute _pm Proxy req = do

210+ _response <- runRequest req { requestMethod = method }

211+ return NoContent

212+ where method = reflectMethod (Proxy :: Proxy method)

213+

214+instance OVERLAPPING_

215+ -- Note [Non-Empty Content Types]

216+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls

217+ , ReflectMethod method, cts' ~ (ct ': cts)

218+ ) => HasClient m (Verb method status cts' (Headers ls a)) where

219+ type Client m (Verb method status cts' (Headers ls a))

220+ = m (Headers ls a)

221+ clientWithRoute _pm Proxy req = do

222+ response <- runRequest req

223+ { requestMethod = method

224+ , requestAccept = fromList $ toList accept

225+ }

226+ case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of

227+ Left err -> throwServantError $ DecodeFailure (pack err) response

228+ Right val -> return $ Headers

229+ { getResponse = val

230+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

231+ }

232+ where method = reflectMethod (Proxy :: Proxy method)

233+ accept = contentTypes (Proxy :: Proxy ct)

234+

235+instance OVERLAPPING_

236+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method

237+ ) => HasClient m (Verb method status cts (Headers ls NoContent)) where

238+ type Client m (Verb method status cts (Headers ls NoContent))

239+ = m (Headers ls NoContent)

240+ clientWithRoute _pm Proxy req = do

241+ let method = reflectMethod (Proxy :: Proxy method)

242+ response <- runRequest req { requestMethod = method }

243+ return $ Headers { getResponse = NoContent

244+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response

245+ }

246+

247+

248+-- | If you use a 'Header' in one of your endpoints in your API,

249+-- the corresponding querying function will automatically take

250+-- an additional argument of the type specified by your 'Header',

251+-- wrapped in Maybe.

252+--

253+-- That function will take care of encoding this argument as Text

254+-- in the request headers.

255+--

256+-- All you need is for your type to have a 'ToHttpApiData' instance.

257+--

258+-- Example:

259+--

260+-- > newtype Referer = Referer { referrer :: Text }

261+-- > deriving (Eq, Show, Generic, ToHttpApiData)

262+-- >

263+-- > -- GET /view-my-referer

264+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer

265+-- >

266+-- > myApi :: Proxy MyApi

267+-- > myApi = Proxy

268+-- >

269+-- > viewReferer :: Maybe Referer -> ClientM Book

270+-- > viewReferer = client myApi

271+-- > -- then you can just use "viewRefer" to query that endpoint

272+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

273+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

274+ => HasClient m (Header sym a :> api) where

275+

276+ type Client m (Header sym a :> api) =

277+ Maybe a -> Client m api

278+

279+ clientWithRoute pm Proxy req mval =

280+ clientWithRoute pm (Proxy :: Proxy api)

281+ (maybe req

282+ (\value -> addHeader hname value req)

283+ mval

284+ )

285+

286+ where hname = fromString $ symbolVal (Proxy :: Proxy sym)

287+

288+-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

289+-- functions.

290+instance HasClient m api

291+ => HasClient m (HttpVersion :> api) where

292+

293+ type Client m (HttpVersion :> api) =

294+ Client m api

295+

296+ clientWithRoute pm Proxy =

297+ clientWithRoute pm (Proxy :: Proxy api)

298+

299+-- | Ignore @'Summary'@ in client functions.

300+instance HasClient m api => HasClient m (Summary desc :> api) where

301+ type Client m (Summary desc :> api) = Client m api

302+

303+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

304+

305+-- | Ignore @'Description'@ in client functions.

306+instance HasClient m api => HasClient m (Description desc :> api) where

307+ type Client m (Description desc :> api) = Client m api

308+

309+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)

310+

311+-- | If you use a 'QueryParam' in one of your endpoints in your API,

312+-- the corresponding querying function will automatically take

313+-- an additional argument of the type specified by your 'QueryParam',

314+-- enclosed in Maybe.

315+--

316+-- If you give Nothing, nothing will be added to the query string.

317+--

318+-- If you give a non-'Nothing' value, this function will take care

319+-- of inserting a textual representation of this value in the query string.

320+--

321+-- You can control how values for your type are turned into

322+-- text by specifying a 'ToHttpApiData' instance for your type.

323+--

324+-- Example:

325+--

326+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]

327+-- >

328+-- > myApi :: Proxy MyApi

329+-- > myApi = Proxy

330+-- >

331+-- > getBooksBy :: Maybe Text -> ClientM [Book]

332+-- > getBooksBy = client myApi

333+-- > -- then you can just use "getBooksBy" to query that endpoint.

334+-- > -- 'getBooksBy Nothing' for all books

335+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

336+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

337+ => HasClient m (QueryParam sym a :> api) where

338+

339+ type Client m (QueryParam sym a :> api) =

340+ Maybe a -> Client m api

341+

342+ -- if mparam = Nothing, we don't add it to the query string

343+ clientWithRoute pm Proxy req mparam =

344+ clientWithRoute pm (Proxy :: Proxy api)

345+ (maybe req

346+ (flip (appendToQueryString pname) req . Just)

347+ mparamText

348+ )

349+

350+ where pname = pack $ symbolVal (Proxy :: Proxy sym)

351+ mparamText = fmap toQueryParam mparam

352+

353+-- | If you use a 'QueryParams' in one of your endpoints in your API,

354+-- the corresponding querying function will automatically take

355+-- an additional argument, a list of values of the type specified

356+-- by your 'QueryParams'.

357+--

358+-- If you give an empty list, nothing will be added to the query string.

359+--

360+-- Otherwise, this function will take care

361+-- of inserting a textual representation of your values in the query string,

362+-- under the same query string parameter name.

363+--

364+-- You can control how values for your type are turned into

365+-- text by specifying a 'ToHttpApiData' instance for your type.

366+--

367+-- Example:

368+--

369+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]

370+-- >

371+-- > myApi :: Proxy MyApi

372+-- > myApi = Proxy

373+-- >

374+-- > getBooksBy :: [Text] -> ClientM [Book]

375+-- > getBooksBy = client myApi

376+-- > -- then you can just use "getBooksBy" to query that endpoint.

377+-- > -- 'getBooksBy []' for all books

378+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'

379+-- > -- to get all books by Asimov and Heinlein

380+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)

381+ => HasClient m (QueryParams sym a :> api) where

382+

383+ type Client m (QueryParams sym a :> api) =

384+ [a] -> Client m api

385+

386+ clientWithRoute pm Proxy req paramlist =

387+ clientWithRoute pm (Proxy :: Proxy api)

388+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))

389+ req

390+ paramlist'

391+ )

392+

393+ where pname = pack $ symbolVal (Proxy :: Proxy sym)

394+ paramlist' = map (Just . toQueryParam) paramlist

395+

396+-- | If you use a 'QueryFlag' in one of your endpoints in your API,

397+-- the corresponding querying function will automatically take

398+-- an additional 'Bool' argument.

399+--

400+-- If you give 'False', nothing will be added to the query string.

401+--

402+-- Otherwise, this function will insert a value-less query string

403+-- parameter under the name associated to your 'QueryFlag'.

404+--

405+-- Example:

406+--

407+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]

408+-- >

409+-- > myApi :: Proxy MyApi

410+-- > myApi = Proxy

411+-- >

412+-- > getBooks :: Bool -> ClientM [Book]

413+-- > getBooks = client myApi

414+-- > -- then you can just use "getBooks" to query that endpoint.

415+-- > -- 'getBooksBy False' for all books

416+-- > -- 'getBooksBy True' to only get _already published_ books

417+instance (KnownSymbol sym, HasClient m api)

418+ => HasClient m (QueryFlag sym :> api) where

419+

420+ type Client m (QueryFlag sym :> api) =

421+ Bool -> Client m api

422+

423+ clientWithRoute pm Proxy req flag =

424+ clientWithRoute pm (Proxy :: Proxy api)

425+ (if flag

426+ then appendToQueryString paramname Nothing req

427+ else req

428+ )

429+

430+ where paramname = pack $ symbolVal (Proxy :: Proxy sym)

431+

432+

433+-- | Pick a 'Method' and specify where the server you want to query is. You get

434+-- back the full `Response`.

435+instance RunClient m => HasClient m Raw where

436+ type Client m Raw

437+ = H.Method -> m Response

438+

439+ clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw

440+ clientWithRoute _pm Proxy req httpMethod = do

441+ runRequest req { requestMethod = httpMethod }

442+

443+-- | If you use a 'ReqBody' in one of your endpoints in your API,

444+-- the corresponding querying function will automatically take

445+-- an additional argument of the type specified by your 'ReqBody'.

446+-- That function will take care of encoding this argument as JSON and

447+-- of using it as the request body.

448+--

449+-- All you need is for your type to have a 'ToJSON' instance.

450+--

451+-- Example:

452+--

453+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

454+-- >

455+-- > myApi :: Proxy MyApi

456+-- > myApi = Proxy

457+-- >

458+-- > addBook :: Book -> ClientM Book

459+-- > addBook = client myApi

460+-- > -- then you can just use "addBook" to query that endpoint

461+instance (MimeRender ct a, HasClient m api)

462+ => HasClient m (ReqBody (ct ': cts) a :> api) where

463+

464+ type Client m (ReqBody (ct ': cts) a :> api) =

465+ a -> Client m api

466+

467+ clientWithRoute pm Proxy req body =

468+ clientWithRoute pm (Proxy :: Proxy api)

469+ (let ctProxy = Proxy :: Proxy ct

470+ in setRequestBodyLBS (mimeRender ctProxy body)

471+ -- We use first contentType from the Accept list

472+ (contentType ctProxy)

473+ req

474+ )

475+

476+-- | Make the querying function append @path@ to the request path.

477+instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where

478+ type Client m (path :> api) = Client m api

479+

480+ clientWithRoute pm Proxy req =

481+ clientWithRoute pm (Proxy :: Proxy api)

482+ (appendToPath p req)

483+

484+ where p = pack $ symbolVal (Proxy :: Proxy path)

485+

486+instance HasClient m api => HasClient m (Vault :> api) where

487+ type Client m (Vault :> api) = Client m api

488+

489+ clientWithRoute pm Proxy req =

490+ clientWithRoute pm (Proxy :: Proxy api) req

491+

492+instance HasClient m api => HasClient m (RemoteHost :> api) where

493+ type Client m (RemoteHost :> api) = Client m api

494+

495+ clientWithRoute pm Proxy req =

496+ clientWithRoute pm (Proxy :: Proxy api) req

497+

498+instance HasClient m api => HasClient m (IsSecure :> api) where

499+ type Client m (IsSecure :> api) = Client m api

500+

501+ clientWithRoute pm Proxy req =

502+ clientWithRoute pm (Proxy :: Proxy api) req

503+

504+instance HasClient m subapi =>

505+ HasClient m (WithNamedContext name context subapi) where

506+

507+ type Client m (WithNamedContext name context subapi) = Client m subapi

508+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)

509+

510+instance ( HasClient m api

511+ ) => HasClient m (AuthProtect tag :> api) where

512+ type Client m (AuthProtect tag :> api)

513+ = AuthenticatedRequest (AuthProtect tag) -> Client m api

514+

515+ clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =

516+ clientWithRoute pm (Proxy :: Proxy api) (func val req)

517+

518+-- * Basic Authentication

519+

520+instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where

521+ type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api

522+

523+ clientWithRoute pm Proxy req val =

524+ clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)

525+

526+

527+{- Note [Non-Empty Content Types]

528+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

529+Rather than have

530+

531+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...

532+

533+It may seem to make more sense to have:

534+

535+ instance (...) => ... (ct ': cts) ...

536+

537+But this means that if another instance exists that does *not* require

538+non-empty lists, but is otherwise more specific, no instance will be overall

539+more specific. This in turn generally means adding yet another instance (one

540+for empty and one for non-empty lists).

541+-}

servant-client-core/src/Servant/Client/Core/Internal/Request.hsnew file+117

@@ -0,0 +1,117 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+

11+module Servant.Client.Core.Internal.Request where

12+

13+import Prelude ()

14+import Prelude.Compat

15+

16+import Control.Monad.Catch (Exception)

17+import qualified Data.ByteString.Builder as Builder

18+import qualified Data.ByteString.Lazy as LBS

19+import Data.Semigroup ((<>))

20+import qualified Data.Sequence as Seq

21+import Data.Text (Text)

22+import Data.Text.Encoding (encodeUtf8)

23+import Data.Typeable (Typeable)

24+import GHC.Generics (Generic)

25+import Network.HTTP.Media (MediaType)

26+import Network.HTTP.Types (Header, HeaderName, HttpVersion,

27+ Method, QueryItem, Status, http11,

28+ methodGet)

29+import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,

30+ toHeader)

31+

32+-- | A type representing possible errors in a request

33+--

34+-- Note that this type substantially changed in 0.12.

35+data ServantError =

36+ -- | The server returned an error response

37+ FailureResponse Response

38+ -- | The body could not be decoded at the expected type

39+ | DecodeFailure Text Response

40+ -- | The content-type of the response is not supported

41+ | UnsupportedContentType MediaType Response

42+ -- | The content-type header is invalid

43+ | InvalidContentTypeHeader Response

44+ -- | There was a connection error, and no response was received

45+ | ConnectionError Text

46+ deriving (Eq, Show, Generic, Typeable)

47+

48+instance Exception ServantError

49+

50+data RequestF a = Request

51+ { requestPath :: a

52+ , requestQueryString :: Seq.Seq QueryItem

53+ , requestBody :: Maybe (RequestBody, MediaType)

54+ , requestAccept :: Seq.Seq MediaType

55+ , requestHeaders :: Seq.Seq Header

56+ , requestHttpVersion :: HttpVersion

57+ , requestMethod :: Method

58+ } deriving (Eq, Show, Functor, Generic, Typeable)

59+

60+type Request = RequestF Builder.Builder

61+

62+-- | The request body. Currently only lazy ByteStrings are supported.

63+newtype RequestBody = RequestBodyLBS LBS.ByteString

64+ deriving (Eq, Ord, Read, Show, Typeable)

65+

66+data Response = Response

67+ { responseStatusCode :: Status

68+ , responseBody :: LBS.ByteString

69+ , responseHeaders :: Seq.Seq Header

70+ , responseHttpVersion :: HttpVersion

71+ } deriving (Eq, Show, Generic, Typeable)

72+

73+-- A GET request to the top-level path

74+defaultRequest :: Request

75+defaultRequest = Request

76+ { requestPath = ""

77+ , requestQueryString = Seq.empty

78+ , requestBody = Nothing

79+ , requestAccept = Seq.empty

80+ , requestHeaders = Seq.empty

81+ , requestHttpVersion = http11

82+ , requestMethod = methodGet

83+ }

84+

85+appendToPath :: Text -> Request -> Request

86+appendToPath p req

87+ = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }

88+

89+appendToQueryString :: Text -- ^ param name

90+ -> Maybe Text -- ^ param value

91+ -> Request

92+ -> Request

93+appendToQueryString pname pvalue req

94+ = req { requestQueryString = requestQueryString req

95+ Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}

96+

97+addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request

98+addHeader name val req

99+ = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}

100+

101+-- | Set body and media type of the request being constructed.

102+--

103+-- The body is set to the given bytestring using the 'RequestBodyLBS'

104+-- constructor.

105+--

106+-- @since 0.12

107+--

108+setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request

109+setRequestBodyLBS b t req

110+ = req { requestBody = Just (RequestBodyLBS b, t) }

111+

112+-- | Set body and media type of the request being constructed.

113+--

114+-- @since 0.12

115+--

116+setRequestBody :: RequestBody -> MediaType -> Request -> Request

117+setRequestBody b t req = req { requestBody = Just (b, t) }

servant-client-core/src/Servant/Client/Core/Internal/RunClient.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeFamilies #-}

6+-- | Types for possible backends to run client-side `Request` queries

7+module Servant.Client.Core.Internal.RunClient where

9+import Prelude ()

10+import Prelude.Compat

11+

12+import Control.Monad (unless)

13+import Data.Foldable (toList)

14+import Data.Proxy (Proxy)

15+import qualified Data.Text as T

16+import Network.HTTP.Media (MediaType, matches,

17+ parseAccept, (//))

18+import Servant.API (MimeUnrender,

19+ contentTypes,

20+ mimeUnrender)

21+import Servant.Client.Core.Internal.Request (Request, Response (..),

22+ ServantError (..))

23+

24+class (Monad m) => RunClient m where

25+ -- | How to make a request.

26+ runRequest :: Request -> m Response

27+ throwServantError :: ServantError -> m a

28+ catchServantError :: m a -> (ServantError -> m a) -> m a

29+

30+checkContentTypeHeader :: RunClient m => Response -> m MediaType

31+checkContentTypeHeader response =

32+ case lookup "Content-Type" $ toList $ responseHeaders response of

33+ Nothing -> return $ "application"//"octet-stream"

34+ Just t -> case parseAccept t of

35+ Nothing -> throwServantError $ InvalidContentTypeHeader response

36+ Just t' -> return t'

37+

38+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)

39+ => Response -> Proxy ct -> m a

40+decodedAs response contentType = do

41+ responseContentType <- checkContentTypeHeader response

42+ unless (any (matches responseContentType) accept) $

43+ throwServantError $ UnsupportedContentType responseContentType response

44+ case mimeUnrender contentType $ responseBody response of

45+ Left err -> throwServantError $ DecodeFailure (T.pack err) response

46+ Right val -> return val

47+ where

48+ accept = toList $ contentTypes contentType

servant-client-core/src/Servant/Client/Core/Reexport.hsnew file+30

@@ -0,0 +1,30 @@

1+-- | This module is a utility for @servant-client-core@ backend writers. It

2+-- contains all the functionality from @servant-client-core@ that should be

3+-- re-exported.

4+module Servant.Client.Core.Reexport

5+ (

6+ -- * HasClient

7+ HasClient(..)

8+ -- * Response (for @Raw@)

9+ , Response(..)

10+

11+ -- * Generic Client

12+ , ClientLike(..)

13+ , genericMkClientL

14+ , genericMkClientP

15+ , ServantError(..)

16+ , EmptyClient(..)

17+

18+ -- * BaseUrl

19+ , BaseUrl(..)

20+ , Scheme(..)

21+ , showBaseUrl

22+ , parseBaseUrl

23+ , InvalidBaseUrlException

24+ ) where

25+

26+

27+import Servant.Client.Core.Internal.BaseUrl

28+import Servant.Client.Core.Internal.HasClient

29+import Servant.Client.Core.Internal.Generic

30+import Servant.Client.Core.Internal.Request

servant-client/test/Servant/Common/BaseUrlSpec.hs → servant-client-core/test/Servant/Client/Core/Internal/BaseUrlSpec.hsrenamed+3−5

@@ -1,5 +1,6 @@

11{-# OPTIONS_GHC -fno-warn-orphans #-}

2−module Servant.Common.BaseUrlSpec where

2+module Servant.Client.Core.Internal.BaseUrlSpec (spec) where

45import Control.DeepSeq

56import Prelude ()

@@ -7,7 +8,7 @@ import Prelude.Compat

78import Test.Hspec

89import Test.QuickCheck

910

10−import Servant.Common.BaseUrl

11+import Servant.Client.Core.Internal.BaseUrl

1112

1213spec :: Spec

1314spec = do

@@ -78,6 +79,3 @@ instance Arbitrary BaseUrl where

7879 (1, choose (1, 20000)) :

7980 []

8081 pathGen = listOf1 . elements $ letters

81−

82−isLeft :: Either a b -> Bool

83−isLeft = either (const True) (const False)

servant-client-core/test/Spec.hsnew file+1

@@ -0,0 +1 @@

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

servant-client/servant-client.cabal+10−21

@@ -12,7 +12,7 @@ license: BSD3

1212license-file: LICENSE

1313author: Servant Contributors

1414maintainer: haskell-servant-maintainers@googlegroups.com

15−copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors

15+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors

1616category: Servant, Web

1717build-type: Simple

1818cabal-version: >=1.10

@@ -30,39 +30,27 @@ source-repository head

3030library

3131 exposed-modules:

3232 Servant.Client

33− Servant.Client.Generic

34− Servant.Client.Experimental.Auth

35− Servant.Common.BaseUrl

36− Servant.Common.BasicAuth

37− Servant.Common.Req

33+ Servant.Client.Internal.HttpClient

3834 build-depends:

3935 base >= 4.7 && < 4.11

4036 , base-compat >= 0.9.1 && < 0.10

37+ , bytestring >= 0.10 && < 0.11

4138 , aeson >= 0.7 && < 1.3

4239 , attoparsec >= 0.12 && < 0.14

43− , base64-bytestring >= 1.0.0.1 && < 1.1

44− , bytestring >= 0.10 && < 0.11

45− , exceptions >= 0.8 && < 0.9

46− , generics-sop >= 0.1.0.0 && < 0.4

47− , http-api-data >= 0.3.6 && < 0.4

48− , http-client >= 0.4.18.1 && < 0.6

40+ , containers >= 0.5 && < 0.6

41+ , http-client >= 0.4.30 && < 0.6

4942 , http-client-tls >= 0.2.2 && < 0.4

5043 , http-media >= 0.6.2 && < 0.8

5144 , http-types >= 0.8.6 && < 0.10

45+ , exceptions >= 0.8 && < 0.9

5246 , monad-control >= 1.0.0.4 && < 1.1

53− , network-uri >= 2.6 && < 2.7

54− , safe >= 0.3.9 && < 0.4

47+ , mtl >= 2.1 && < 2.3

5548 , semigroupoids >= 4.3 && < 5.3

56− , servant == 0.11.*

57− , string-conversions >= 0.3 && < 0.5

49+ , servant-client-core == 0.11.*

5850 , text >= 1.2 && < 1.3

5951 , transformers >= 0.3 && < 0.6

6052 , transformers-base >= 0.4.4 && < 0.5

6153 , transformers-compat >= 0.4 && < 0.6

62− , mtl

63− if !impl(ghc >= 8.0)

64− build-depends:

65− semigroups >=0.16.2.2 && <0.19

6654 hs-source-dirs: src

6755 default-language: Haskell2010

6856 ghc-options: -Wall

@@ -78,12 +66,12 @@ test-suite spec

7866 main-is: Spec.hs

7967 other-modules:

8068 Servant.ClientSpec

81− , Servant.Common.BaseUrlSpec

8269 build-depends:

8370 base == 4.*

8471 , aeson

8572 , base-compat

8673 , bytestring

74+ , containers

8775 , deepseq

8876 , hspec == 2.*

8977 , http-api-data

@@ -96,6 +84,7 @@ test-suite spec

9684 , QuickCheck >= 2.7

9785 , servant

9886 , servant-client

87+ , servant-client-core

9988 , servant-server == 0.11.*

10089 , text

10190 , transformers

servant-client/src/Servant/Client.hs+5−502

@@ -1,510 +1,13 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE InstanceSigs #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−

13−#include "overlapping-compat.h"

141-- | This module provides 'client' which can automatically generate

152-- querying functions for each endpoint just from the type representing your

163-- API.

174module Servant.Client

18− ( AuthClientData

19− , AuthenticateReq(..)

20− , client

21− , HasClient(..)

5+ ( client

226 , ClientM

237 , runClientM

24− , ClientEnv (ClientEnv)

25− , mkAuthenticateReq

26− , ServantError(..)

27− , EmptyClient(..)

28− , module Servant.Common.BaseUrl

8+ , ClientEnv(..)

9+ , module Servant.Client.Core.Reexport

2910 ) where

3011

31−import Data.ByteString.Lazy (ByteString)

32−import Data.List

33−import Data.Proxy

34−import Data.String.Conversions

35−import Data.Text (unpack)

36−import GHC.TypeLits

37−import Network.HTTP.Client (Response)

38−import Network.HTTP.Media

39−import qualified Network.HTTP.Types as H

40−import qualified Network.HTTP.Types.Header as HTTP

41−import Prelude ()

42−import Prelude.Compat

43−import Servant.API

44−import Servant.Client.Experimental.Auth

45−import Servant.Common.BaseUrl

46−import Servant.Common.BasicAuth

47−import Servant.Common.Req

48−

49−-- * Accessing APIs as a Client

50−

51−-- | 'client' allows you to produce operations to query an API from a client.

52−--

53−-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

54−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books

55−-- >

56−-- > myApi :: Proxy MyApi

57−-- > myApi = Proxy

58−-- >

59−-- > getAllBooks :: ClientM [Book]

60−-- > postNewBook :: Book -> ClientM Book

61−-- > (getAllBooks :<|> postNewBook) = client myApi

62−client :: HasClient api => Proxy api -> Client api

63−client p = clientWithRoute p defReq

64−

65−-- | This class lets us define how each API combinator

66−-- influences the creation of an HTTP request. It's mostly

67−-- an internal class, you can just use 'client'.

68−class HasClient api where

69− type Client api :: *

70− clientWithRoute :: Proxy api -> Req -> Client api

71−

72−

73−-- | A client querying function for @a ':<|>' b@ will actually hand you

74−-- one function for querying @a@ and another one for querying @b@,

75−-- stitching them together with ':<|>', which really is just like a pair.

76−--

77−-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books

78−-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books

79−-- >

80−-- > myApi :: Proxy MyApi

81−-- > myApi = Proxy

82−-- >

83−-- > getAllBooks :: ClientM [Book]

84−-- > postNewBook :: Book -> ClientM Book

85−-- > (getAllBooks :<|> postNewBook) = client myApi

86−instance (HasClient a, HasClient b) => HasClient (a :<|> b) where

87− type Client (a :<|> b) = Client a :<|> Client b

88− clientWithRoute Proxy req =

89− clientWithRoute (Proxy :: Proxy a) req :<|>

90− clientWithRoute (Proxy :: Proxy b) req

91−

92−-- | Singleton type representing a client for an empty API.

93−data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)

94−

95−-- | The client for 'EmptyAPI' is simply 'EmptyClient'.

96−--

97−-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books

98−-- > :<|> "nothing" :> EmptyAPI

99−-- >

100−-- > myApi :: Proxy MyApi

101−-- > myApi = Proxy

102−-- >

103−-- > getAllBooks :: ClientM [Book]

104−-- > (getAllBooks :<|> EmptyClient) = client myApi

105−instance HasClient EmptyAPI where

106− type Client EmptyAPI = EmptyClient

107− clientWithRoute Proxy _ = EmptyClient

108−

109−-- | If you use a 'Capture' in one of your endpoints in your API,

110−-- the corresponding querying function will automatically take

111−-- an additional argument of the type specified by your 'Capture'.

112−-- That function will take care of inserting a textual representation

113−-- of this value at the right place in the request path.

114−--

115−-- You can control how values for this type are turned into

116−-- text by specifying a 'ToHttpApiData' instance for your type.

117−--

118−-- Example:

119−--

120−-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

121−-- >

122−-- > myApi :: Proxy MyApi

123−-- > myApi = Proxy

124−-- >

125−-- > getBook :: Text -> ClientM Book

126−-- > getBook = client myApi

127−-- > -- then you can just use "getBook" to query that endpoint

128−instance (KnownSymbol capture, ToHttpApiData a, HasClient api)

129− => HasClient (Capture capture a :> api) where

130−

131− type Client (Capture capture a :> api) =

132− a -> Client api

133−

134− clientWithRoute Proxy req val =

135− clientWithRoute (Proxy :: Proxy api)

136− (appendToPath p req)

137−

138− where p = unpack (toUrlPiece val)

139−

140−-- | If you use a 'CaptureAll' in one of your endpoints in your API,

141−-- the corresponding querying function will automatically take an

142−-- additional argument of a list of the type specified by your

143−-- 'CaptureAll'. That function will take care of inserting a textual

144−-- representation of this value at the right place in the request

145−-- path.

146−--

147−-- You can control how these values are turned into text by specifying

148−-- a 'ToHttpApiData' instance of your type.

149−--

150−-- Example:

151−--

152−-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile

153−-- >

154−-- > myApi :: Proxy

155−-- > myApi = Proxy

156−--

157−-- > getSourceFile :: [Text] -> ClientM SourceFile

158−-- > getSourceFile = client myApi

159−-- > -- then you can use "getSourceFile" to query that endpoint

160−instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)

161− => HasClient (CaptureAll capture a :> sublayout) where

162−

163− type Client (CaptureAll capture a :> sublayout) =

164− [a] -> Client sublayout

165−

166− clientWithRoute Proxy req vals =

167− clientWithRoute (Proxy :: Proxy sublayout)

168− (foldl' (flip appendToPath) req ps)

169−

170− where ps = map (unpack . toUrlPiece) vals

171−

172−instance OVERLAPPABLE_

173− -- Note [Non-Empty Content Types]

174− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

175− ) => HasClient (Verb method status cts' a) where

176− type Client (Verb method status cts' a) = ClientM a

177− clientWithRoute Proxy req = do

178− snd <$> performRequestCT (Proxy :: Proxy ct) method req

179− where method = reflectMethod (Proxy :: Proxy method)

180−

181−instance OVERLAPPING_

182− (ReflectMethod method) => HasClient (Verb method status cts NoContent) where

183− type Client (Verb method status cts NoContent)

184− = ClientM NoContent

185− clientWithRoute Proxy req = do

186− performRequestNoBody method req >> return NoContent

187− where method = reflectMethod (Proxy :: Proxy method)

188−

189−instance OVERLAPPING_

190− -- Note [Non-Empty Content Types]

191− ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)

192− ) => HasClient (Verb method status cts' (Headers ls a)) where

193− type Client (Verb method status cts' (Headers ls a))

194− = ClientM (Headers ls a)

195− clientWithRoute Proxy req = do

196− let method = reflectMethod (Proxy :: Proxy method)

197− (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req

198− return $ Headers { getResponse = resp

199− , getHeadersHList = buildHeadersTo hdrs

200− }

201−

202−instance OVERLAPPING_

203− ( BuildHeadersTo ls, ReflectMethod method

204− ) => HasClient (Verb method status cts (Headers ls NoContent)) where

205− type Client (Verb method status cts (Headers ls NoContent))

206− = ClientM (Headers ls NoContent)

207− clientWithRoute Proxy req = do

208− let method = reflectMethod (Proxy :: Proxy method)

209− hdrs <- performRequestNoBody method req

210− return $ Headers { getResponse = NoContent

211− , getHeadersHList = buildHeadersTo hdrs

212− }

213−

214−

215−-- | If you use a 'Header' in one of your endpoints in your API,

216−-- the corresponding querying function will automatically take

217−-- an additional argument of the type specified by your 'Header',

218−-- wrapped in Maybe.

219−--

220−-- That function will take care of encoding this argument as Text

221−-- in the request headers.

222−--

223−-- All you need is for your type to have a 'ToHttpApiData' instance.

224−--

225−-- Example:

226−--

227−-- > newtype Referer = Referer { referrer :: Text }

228−-- > deriving (Eq, Show, Generic, ToHttpApiData)

229−-- >

230−-- > -- GET /view-my-referer

231−-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer

232−-- >

233−-- > myApi :: Proxy MyApi

234−-- > myApi = Proxy

235−-- >

236−-- > viewReferer :: Maybe Referer -> ClientM Book

237−-- > viewReferer = client myApi

238−-- > -- then you can just use "viewRefer" to query that endpoint

239−-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

240−instance (KnownSymbol sym, ToHttpApiData a, HasClient api)

241− => HasClient (Header sym a :> api) where

242−

243− type Client (Header sym a :> api) =

244− Maybe a -> Client api

245−

246− clientWithRoute Proxy req mval =

247− clientWithRoute (Proxy :: Proxy api)

248− (maybe req

249− (\value -> Servant.Common.Req.addHeader hname value req)

250− mval

251− )

252−

253− where hname = symbolVal (Proxy :: Proxy sym)

254−

255−-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

256−-- functions.

257−instance HasClient api

258− => HasClient (HttpVersion :> api) where

259−

260− type Client (HttpVersion :> api) =

261− Client api

262−

263− clientWithRoute Proxy =

264− clientWithRoute (Proxy :: Proxy api)

265−

266−-- | Ignore @'Summary'@ in client functions.

267−instance HasClient api => HasClient (Summary desc :> api) where

268− type Client (Summary desc :> api) = Client api

269−

270− clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)

271−

272−-- | Ignore @'Description'@ in client functions.

273−instance HasClient api => HasClient (Description desc :> api) where

274− type Client (Description desc :> api) = Client api

275−

276− clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)

277−

278−-- | If you use a 'QueryParam' in one of your endpoints in your API,

279−-- the corresponding querying function will automatically take

280−-- an additional argument of the type specified by your 'QueryParam',

281−-- enclosed in Maybe.

282−--

283−-- If you give Nothing, nothing will be added to the query string.

284−--

285−-- If you give a non-'Nothing' value, this function will take care

286−-- of inserting a textual representation of this value in the query string.

287−--

288−-- You can control how values for your type are turned into

289−-- text by specifying a 'ToHttpApiData' instance for your type.

290−--

291−-- Example:

292−--

293−-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]

294−-- >

295−-- > myApi :: Proxy MyApi

296−-- > myApi = Proxy

297−-- >

298−-- > getBooksBy :: Maybe Text -> ClientM [Book]

299−-- > getBooksBy = client myApi

300−-- > -- then you can just use "getBooksBy" to query that endpoint.

301−-- > -- 'getBooksBy Nothing' for all books

302−-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

303−instance (KnownSymbol sym, ToHttpApiData a, HasClient api)

304− => HasClient (QueryParam sym a :> api) where

305−

306− type Client (QueryParam sym a :> api) =

307− Maybe a -> Client api

308−

309− -- if mparam = Nothing, we don't add it to the query string

310− clientWithRoute Proxy req mparam =

311− clientWithRoute (Proxy :: Proxy api)

312− (maybe req

313− (flip (appendToQueryString pname) req . Just)

314− mparamText

315− )

316−

317− where pname = cs pname'

318− pname' = symbolVal (Proxy :: Proxy sym)

319− mparamText = fmap toQueryParam mparam

320−

321−-- | If you use a 'QueryParams' in one of your endpoints in your API,

322−-- the corresponding querying function will automatically take

323−-- an additional argument, a list of values of the type specified

324−-- by your 'QueryParams'.

325−--

326−-- If you give an empty list, nothing will be added to the query string.

327−--

328−-- Otherwise, this function will take care

329−-- of inserting a textual representation of your values in the query string,

330−-- under the same query string parameter name.

331−--

332−-- You can control how values for your type are turned into

333−-- text by specifying a 'ToHttpApiData' instance for your type.

334−--

335−-- Example:

336−--

337−-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]

338−-- >

339−-- > myApi :: Proxy MyApi

340−-- > myApi = Proxy

341−-- >

342−-- > getBooksBy :: [Text] -> ClientM [Book]

343−-- > getBooksBy = client myApi

344−-- > -- then you can just use "getBooksBy" to query that endpoint.

345−-- > -- 'getBooksBy []' for all books

346−-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'

347−-- > -- to get all books by Asimov and Heinlein

348−instance (KnownSymbol sym, ToHttpApiData a, HasClient api)

349− => HasClient (QueryParams sym a :> api) where

350−

351− type Client (QueryParams sym a :> api) =

352− [a] -> Client api

353−

354− clientWithRoute Proxy req paramlist =

355− clientWithRoute (Proxy :: Proxy api)

356− (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))

357− req

358− paramlist'

359− )

360−

361− where pname = cs pname'

362− pname' = symbolVal (Proxy :: Proxy sym)

363− paramlist' = map (Just . toQueryParam) paramlist

364−

365−-- | If you use a 'QueryFlag' in one of your endpoints in your API,

366−-- the corresponding querying function will automatically take

367−-- an additional 'Bool' argument.

368−--

369−-- If you give 'False', nothing will be added to the query string.

370−--

371−-- Otherwise, this function will insert a value-less query string

372−-- parameter under the name associated to your 'QueryFlag'.

373−--

374−-- Example:

375−--

376−-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]

377−-- >

378−-- > myApi :: Proxy MyApi

379−-- > myApi = Proxy

380−-- >

381−-- > getBooks :: Bool -> ClientM [Book]

382−-- > getBooks = client myApi

383−-- > -- then you can just use "getBooks" to query that endpoint.

384−-- > -- 'getBooksBy False' for all books

385−-- > -- 'getBooksBy True' to only get _already published_ books

386−instance (KnownSymbol sym, HasClient api)

387− => HasClient (QueryFlag sym :> api) where

388−

389− type Client (QueryFlag sym :> api) =

390− Bool -> Client api

391−

392− clientWithRoute Proxy req flag =

393− clientWithRoute (Proxy :: Proxy api)

394− (if flag

395− then appendToQueryString paramname Nothing req

396− else req

397− )

398−

399− where paramname = cs $ symbolVal (Proxy :: Proxy sym)

400−

401−

402−-- | Pick a 'Method' and specify where the server you want to query is. You get

403−-- back the full `Response`.

404−instance HasClient Raw where

405− type Client Raw

406− = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)

407−

408− clientWithRoute :: Proxy Raw -> Req -> Client Raw

409− clientWithRoute Proxy req httpMethod = do

410− performRequest httpMethod req

411−

412−-- | If you use a 'ReqBody' in one of your endpoints in your API,

413−-- the corresponding querying function will automatically take

414−-- an additional argument of the type specified by your 'ReqBody'.

415−-- That function will take care of encoding this argument as JSON and

416−-- of using it as the request body.

417−--

418−-- All you need is for your type to have a 'ToJSON' instance.

419−--

420−-- Example:

421−--

422−-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book

423−-- >

424−-- > myApi :: Proxy MyApi

425−-- > myApi = Proxy

426−-- >

427−-- > addBook :: Book -> ClientM Book

428−-- > addBook = client myApi

429−-- > -- then you can just use "addBook" to query that endpoint

430−instance (MimeRender ct a, HasClient api)

431− => HasClient (ReqBody (ct ': cts) a :> api) where

432−

433− type Client (ReqBody (ct ': cts) a :> api) =

434− a -> Client api

435−

436− clientWithRoute Proxy req body =

437− clientWithRoute (Proxy :: Proxy api)

438− (let ctProxy = Proxy :: Proxy ct

439− in setReqBodyLBS (mimeRender ctProxy body)

440− -- We use first contentType from the Accept list

441− (contentType ctProxy)

442− req

443− )

444−

445−-- | Make the querying function append @path@ to the request path.

446−instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where

447− type Client (path :> api) = Client api

448−

449− clientWithRoute Proxy req =

450− clientWithRoute (Proxy :: Proxy api)

451− (appendToPath p req)

452−

453− where p = symbolVal (Proxy :: Proxy path)

454−

455−instance HasClient api => HasClient (Vault :> api) where

456− type Client (Vault :> api) = Client api

457−

458− clientWithRoute Proxy req =

459− clientWithRoute (Proxy :: Proxy api) req

460−

461−instance HasClient api => HasClient (RemoteHost :> api) where

462− type Client (RemoteHost :> api) = Client api

463−

464− clientWithRoute Proxy req =

465− clientWithRoute (Proxy :: Proxy api) req

466−

467−instance HasClient api => HasClient (IsSecure :> api) where

468− type Client (IsSecure :> api) = Client api

469−

470− clientWithRoute Proxy req =

471− clientWithRoute (Proxy :: Proxy api) req

472−

473−instance HasClient subapi =>

474− HasClient (WithNamedContext name context subapi) where

475−

476− type Client (WithNamedContext name context subapi) = Client subapi

477− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)

478−

479−instance ( HasClient api

480− ) => HasClient (AuthProtect tag :> api) where

481− type Client (AuthProtect tag :> api)

482− = AuthenticateReq (AuthProtect tag) -> Client api

483−

484− clientWithRoute Proxy req (AuthenticateReq (val,func)) =

485− clientWithRoute (Proxy :: Proxy api) (func val req)

486−

487−-- * Basic Authentication

488−

489−instance HasClient api => HasClient (BasicAuth realm usr :> api) where

490− type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api

491−

492− clientWithRoute Proxy req val =

493− clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)

494−

495−

496−{- Note [Non-Empty Content Types]

497−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

498−Rather than have

499−

500− instance (..., cts' ~ (ct ': cts)) => ... cts' ...

501−

502−It may seem to make more sense to have:

503−

504− instance (...) => ... (ct ': cts) ...

505−

506−But this means that if another instance exists that does *not* require

507−non-empty lists, but is otherwise more specific, no instance will be overall

508−more specific. This in turn generally means adding yet another instance (one

509−for empty and one for non-empty lists).

510−-}

12+import Servant.Client.Internal.HttpClient

13+import Servant.Client.Core.Reexport

servant-client/src/Servant/Client/Internal/HttpClient.hsnew file+149

@@ -0,0 +1,149 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeFamilies #-}

11+

12+-- | @http-client@-based client requests executor

13+module Servant.Client.Internal.HttpClient where

14+

15+

16+import Prelude ()

17+import Prelude.Compat

18+

19+import Control.Exception

20+import Control.Monad

21+import Control.Monad.Base (MonadBase (..))

22+import Control.Monad.Catch (MonadCatch, MonadThrow)

23+import Control.Monad.Error.Class (MonadError (..))

24+import Control.Monad.Reader

25+import Control.Monad.Trans.Control (MonadBaseControl (..))

26+import Control.Monad.Trans.Except

27+import Data.ByteString.Builder (toLazyByteString)

28+import qualified Data.ByteString.Lazy as BSL

29+import Data.Foldable (toList)

30+import Data.Functor.Alt (Alt (..))

31+import Data.Monoid ((<>))

32+import Data.Proxy (Proxy (..))

33+import Data.Sequence (fromList)

34+import Data.String (fromString)

35+import qualified Data.Text as T

36+import GHC.Generics

37+import Network.HTTP.Media (renderHeader)

38+import Network.HTTP.Types (hContentType, renderQuery,

39+ statusCode)

40+import Servant.Client.Core

41+

42+import qualified Network.HTTP.Client as Client

43+

44+-- | The environment in which a request is run.

45+data ClientEnv

46+ = ClientEnv

47+ { manager :: Client.Manager

48+ , baseUrl :: BaseUrl

49+ }

50+

51+-- | Generates a set of client functions for an API.

52+--

53+-- Example:

54+--

55+-- > type API = Capture "no" Int :> Get '[JSON] Int

56+-- > :<|> Get '[JSON] [Bool]

57+-- >

58+-- > api :: Proxy API

59+-- > api = Proxy

60+-- >

61+-- > getInt :: Int -> ClientM Int

62+-- > getBools :: ClientM [Bool]

63+-- > getInt :<|> getBools = client api

64+client :: HasClient ClientM api => Proxy api -> Client ClientM api

65+client api = api `clientIn` (Proxy :: Proxy ClientM)

66+

67+-- | @ClientM@ is the monad in which client functions run. Contains the

68+-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.

69+newtype ClientM a = ClientM

70+ { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

71+ deriving ( Functor, Applicative, Monad, MonadIO, Generic

72+ , MonadReader ClientEnv, MonadError ServantError, MonadThrow

73+ , MonadCatch)

74+

75+instance MonadBase IO ClientM where

76+ liftBase = ClientM . liftBase

77+

78+instance MonadBaseControl IO ClientM where

79+ type StM ClientM a = Either ServantError a

80+

81+ liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

82+

83+ restoreM st = ClientM (restoreM st)

84+

85+-- | Try clients in order, last error is preserved.

86+instance Alt ClientM where

87+ a <!> b = a `catchError` \_ -> b

88+

89+instance RunClient ClientM where

90+ runRequest = performRequest

91+ throwServantError = throwError

92+ catchServantError = catchError

93+

94+instance ClientLike (ClientM a) (ClientM a) where

95+ mkClient = id

96+

97+runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

98+runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm

99+

100+

101+performRequest :: Request -> ClientM Response

102+performRequest req = do

103+ m <- asks manager

104+ burl <- asks baseUrl

105+ let request = requestToClientRequest burl req

106+

107+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m

108+ case eResponse of

109+ Left err -> throwError $ err

110+ Right response -> do

111+ let status = Client.responseStatus response

112+ status_code = statusCode status

113+ ourResponse = clientResponseToReponse response

114+ unless (status_code >= 200 && status_code < 300) $

115+ throwError $ FailureResponse ourResponse

116+ return ourResponse

117+

118+clientResponseToReponse :: Client.Response BSL.ByteString -> Response

119+clientResponseToReponse r = Response

120+ { responseStatusCode = Client.responseStatus r

121+ , responseBody = Client.responseBody r

122+ , responseHeaders = fromList $ Client.responseHeaders r

123+ , responseHttpVersion = Client.responseVersion r

124+ }

125+

126+requestToClientRequest :: BaseUrl -> Request -> Client.Request

127+requestToClientRequest burl r = Client.defaultRequest

128+ { Client.method = requestMethod r

129+ , Client.host = fromString $ baseUrlHost burl

130+ , Client.port = baseUrlPort burl

131+ , Client.path = BSL.toStrict

132+ $ fromString (baseUrlPath burl)

133+ <> toLazyByteString (requestPath r)

134+ , Client.queryString = renderQuery True . toList $ requestQueryString r

135+ , Client.requestHeaders =

136+ let orig = toList $ requestHeaders r

137+ in maybe orig (: orig) contentTypeHdr

138+ , Client.requestBody = body

139+ }

140+ where

141+ (body, contentTypeHdr) = case requestBody r of

142+ Nothing -> (Client.RequestBodyLBS "", Nothing)

143+ Just (RequestBodyLBS body', typ)

144+ -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))

145+

146+catchConnectionError :: IO a -> IO (Either ServantError a)

147+catchConnectionError action =

148+ catch (Right <$> action) $ \e ->

149+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)

servant-client/src/Servant/Common/BasicAuth.hsdeleted−21

@@ -1,21 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TypeSynonymInstances #-}

3−{-# LANGUAGE TypeFamilies #-}

4−

5−-- | Basic Authentication for clients

6−

7−module Servant.Common.BasicAuth (

8− basicAuthReq

9− ) where

10−

11−import Data.ByteString.Base64 (encode)

12−import Data.Monoid ((<>))

13−import Data.Text.Encoding (decodeUtf8)

14−import Servant.Common.Req (addHeader, Req)

15−import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))

16−

17−-- | Authenticate a request using Basic Authentication

18−basicAuthReq :: BasicAuthData -> Req -> Req

19−basicAuthReq (BasicAuthData user pass) req =

20− let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))

21− in addHeader "Authorization" authText req

servant-client/src/Servant/Common/Req.hsdeleted−285

@@ -1,285 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−

10−module Servant.Common.Req where

11−

12−import Prelude ()

13−import Prelude.Compat

14−

15−import Control.Exception

16−import Control.Monad

17−import Control.Monad.Catch (MonadThrow, MonadCatch)

18−import Data.Foldable (toList)

19−import Data.Functor.Alt (Alt (..))

20−import Data.Semigroup ((<>))

21−

22−import Control.Monad.Error.Class (MonadError(..))

23−import Control.Monad.Trans.Except

24−

25−import GHC.Generics

26−import Control.Monad.Base (MonadBase (..))

27−import Control.Monad.IO.Class ()

28−import Control.Monad.Reader

29−import Control.Monad.Trans.Control (MonadBaseControl (..))

30−import qualified Data.ByteString.Builder as BS

31−import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)

32−import Data.String

33−import Data.String.Conversions (cs)

34−import Data.Proxy

35−import Data.Text (Text)

36−import Data.Text.Encoding

37−import Data.Typeable

38−import Network.HTTP.Media

39−import Network.HTTP.Types

40−import Network.HTTP.Client hiding (Proxy, path)

41−import qualified Network.HTTP.Types.Header as HTTP

42−import Network.URI hiding (path)

43−import Servant.API.ContentTypes

44−import Servant.Common.BaseUrl

45−

46−import qualified Network.HTTP.Client as Client

47−

48−import Web.HttpApiData

49−

50−data ServantError

51− = FailureResponse

52− { failingRequest :: UrlReq

53− , responseStatus :: Status

54− , responseContentType :: MediaType

55− , responseBody :: ByteString

56− }

57− | DecodeFailure

58− { decodeError :: String

59− , responseContentType :: MediaType

60− , responseBody :: ByteString

61− }

62− | UnsupportedContentType

63− { responseContentType :: MediaType

64− , responseBody :: ByteString

65− }

66− | InvalidContentTypeHeader

67− { responseContentTypeHeader :: ByteString

68− , responseBody :: ByteString

69− }

70− | ConnectionError

71− { connectionError :: SomeException

72− }

73− deriving (Show, Typeable)

74−

75−instance Eq ServantError where

76− FailureResponse _ a b c == FailureResponse _ x y z =

77− (a, b, c) == (x, y, z)

78− DecodeFailure a b c == DecodeFailure x y z =

79− (a, b, c) == (x, y, z)

80− UnsupportedContentType a b == UnsupportedContentType x y =

81− (a, b) == (x, y)

82− InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =

83− (a, b) == (x, y)

84− ConnectionError a == ConnectionError x =

85− show a == show x

86− _ == _ = False

87−

88−instance Exception ServantError

89−

90−data UrlReq = UrlReq BaseUrl Req

91−

92−instance Show UrlReq where

93− show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)

94− where

95− path = cs (BS.toLazyByteString (reqPath req))

96−

97−data Req = Req

98− { reqPath :: BS.Builder

99− , qs :: QueryText

100− , reqBody :: Maybe (RequestBody, MediaType)

101− , reqAccept :: [MediaType]

102− , headers :: [(String, Text)]

103− }

104−

105−defReq :: Req

106−defReq = Req "" [] Nothing [] []

107−

108−appendToPath :: String -> Req -> Req

109−appendToPath p req =

110− req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }

111−

112−appendToQueryString :: Text -- ^ param name

113− -> Maybe Text -- ^ param value

114− -> Req

115− -> Req

116−appendToQueryString pname pvalue req =

117− req { qs = qs req ++ [(pname, pvalue)]

118− }

119−

120−addHeader :: ToHttpApiData a => String -> a -> Req -> Req

121−addHeader name val req = req { headers = headers req

122− ++ [(name, decodeUtf8 (toHeader val))]

123− }

124−

125−-- | Set body and media type of the request being constructed.

126−--

127−-- The body is set to the given bytestring using the 'RequestBodyLBS'

128−-- constructor.

129−--

130−{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}

131−setRQBody :: ByteString -> MediaType -> Req -> Req

132−setRQBody = setReqBodyLBS

133−

134−-- | Set body and media type of the request being constructed.

135−--

136−-- The body is set to the given bytestring using the 'RequestBodyLBS'

137−-- constructor.

138−--

139−-- @since 0.9.2.0

140−--

141−setReqBodyLBS :: ByteString -> MediaType -> Req -> Req

142−setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }

143−

144−-- | Set body and media type of the request being constructed.

145−--

146−-- @since 0.9.2.0

147−--

148−setReqBody :: RequestBody -> MediaType -> Req -> Req

149−setReqBody b t req = req { reqBody = Just (b, t) }

150−

151−reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

152−reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

153− setheaders . setAccept . setrqb . setQS <$> parseRequest url

154−

155− where url = show $ nullURI { uriScheme = case reqScheme of

156− Http -> "http:"

157− Https -> "https:"

158− , uriAuthority = Just $

159− URIAuth { uriUserInfo = ""

160− , uriRegName = reqHost

161− , uriPort = ":" ++ show reqPort

162− }

163− , uriPath = fullPath

164− }

165− fullPath = path ++ cs (BS.toLazyByteString (reqPath req))

166−

167− setrqb r = case reqBody req of

168− Nothing -> r

169− Just (b,t) -> r { requestBody = b

170− , requestHeaders = requestHeaders r

171− ++ [(hContentType, cs . show $ t)] }

172− setQS = setQueryString $ queryTextToQuery (qs req)

173− setheaders r = r { requestHeaders = requestHeaders r

174− <> fmap toProperHeader (headers req) }

175− setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)

176− <> [("Accept", renderHeader $ reqAccept req)

177− | not . null . reqAccept $ req] }

178− toProperHeader (name, val) =

179− (fromString name, encodeUtf8 val)

180−

181−#if !MIN_VERSION_http_client(0,4,30)

182−-- 'parseRequest' is introduced in http-client-0.4.30

183−-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses

184−--

185−-- See for implementations:

186−-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest

187−-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest

188−parseRequest :: MonadThrow m => String -> m Request

189−parseRequest url = liftM disableStatusCheck (parseUrl url)

190− where

191− disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }

192−#endif

193−

194−

195−-- * performing requests

196−

197−displayHttpRequest :: Method -> String

198−displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"

199−

200−data ClientEnv

201− = ClientEnv

202− { manager :: Manager

203− , baseUrl :: BaseUrl

204− }

205−

206−

207−-- | @ClientM@ is the monad in which client functions run. Contains the

208−-- 'Manager' and 'BaseUrl' used for requests in the reader environment.

209−

210−newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }

211− deriving ( Functor, Applicative, Monad, MonadIO, Generic

212− , MonadReader ClientEnv

213− , MonadError ServantError

214− , MonadThrow, MonadCatch

215− )

216−

217−instance MonadBase IO ClientM where

218− liftBase = ClientM . liftBase

219−

220−instance MonadBaseControl IO ClientM where

221− type StM ClientM a = Either ServantError a

222−

223− -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a

224− liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))

225−

226− -- restoreM :: StM ClientM a -> ClientM a

227− restoreM st = ClientM (restoreM st)

228−

229−-- | Try clients in order, last error is preserved.

230−instance Alt ClientM where

231− a <!> b = a `catchError` \_ -> b

232−

233−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)

234−runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm

235−

236−

237−performRequest :: Method -> Req

238− -> ClientM ( Int, ByteString, MediaType

239− , [HTTP.Header], Response ByteString)

240−performRequest reqMethod req = do

241− m <- asks manager

242− reqHost <- asks baseUrl

243− partialRequest <- liftIO $ reqToRequest req reqHost

244−

245− let request = partialRequest { Client.method = reqMethod }

246−

247− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m

248− case eResponse of

249− Left err ->

250− throwError . ConnectionError $ SomeException err

251−

252− Right response -> do

253− let status = Client.responseStatus response

254− body = Client.responseBody response

255− hdrs = Client.responseHeaders response

256− status_code = statusCode status

257− ct <- case lookup "Content-Type" $ Client.responseHeaders response of

258− Nothing -> pure $ "application"//"octet-stream"

259− Just t -> case parseAccept t of

260− Nothing -> throwError $ InvalidContentTypeHeader (cs t) body

261− Just t' -> pure t'

262− unless (status_code >= 200 && status_code < 300) $

263− throwError $ FailureResponse (UrlReq reqHost req) status ct body

264− return (status_code, body, ct, hdrs, response)

265−

266−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req

267− -> ClientM ([HTTP.Header], result)

268−performRequestCT ct reqMethod req = do

269− let acceptCTS = contentTypes ct

270− (_status, respBody, respCT, hdrs, _response) <-

271− performRequest reqMethod (req { reqAccept = toList acceptCTS })

272− unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody

273− case mimeUnrender ct respBody of

274− Left err -> throwError $ DecodeFailure err respCT respBody

275− Right val -> return (hdrs, val)

276−

277−performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]

278−performRequestNoBody reqMethod req = do

279− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req

280− return hdrs

281−

282−catchConnectionError :: IO a -> IO (Either ServantError a)

283−catchConnectionError action =

284− catch (Right <$> action) $ \e ->

285− pure . Left . ConnectionError $ SomeException (e :: HttpException)

servant-client/test/Servant/ClientSpec.hs+130−113

@@ -24,40 +24,57 @@

2424{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

2525

2626#include "overlapping-compat.h"

27−module Servant.ClientSpec where

27+module Servant.ClientSpec (spec) where

2828

29−import Control.Arrow (left)

30−import Control.Concurrent (forkIO, killThread, ThreadId)

31−import Control.Exception (bracket)

32−import Control.Monad.Error.Class (throwError )

29+import Prelude ()

30+import Prelude.Compat

31+

32+import Control.Arrow (left)

33+import Control.Concurrent (ThreadId, forkIO,

34+ killThread)

35+import Control.Exception (bracket)

36+import Control.Monad.Error.Class (throwError)

3337import Data.Aeson

34−import qualified Data.ByteString.Lazy as BS

35−import Data.Char (chr, isPrint)

36−import Data.Foldable (forM_)

37−import Data.Monoid hiding (getLast)

38+import Data.Char (chr, isPrint)

39+import Data.Foldable (forM_)

40+import Data.Monoid hiding (getLast)

3841import Data.Proxy

39−import qualified Generics.SOP as SOP

40−import GHC.Generics (Generic)

41−import qualified Network.HTTP.Client as C

42−import Network.HTTP.Media

43−import qualified Network.HTTP.Types as HTTP

42+import qualified Generics.SOP as SOP

43+import GHC.Generics (Generic)

44+import qualified Network.HTTP.Client as C

45+import qualified Network.HTTP.Types as HTTP

4446import Network.Socket

45−import Network.Wai (Request, requestHeaders, responseLBS)

47+import qualified Network.Wai as Wai

4648import Network.Wai.Handler.Warp

47−import Prelude ()

48−import Prelude.Compat

49−import System.IO.Unsafe (unsafePerformIO)

50−import Test.HUnit

49+import System.IO.Unsafe (unsafePerformIO)

5150import Test.Hspec

5251import Test.Hspec.QuickCheck

52+import Test.HUnit

5353import Test.QuickCheck

54−import Web.FormUrlEncoded (FromForm, ToForm)

55−

56−import Servant.API

54+import Web.FormUrlEncoded (FromForm, ToForm)

55+

56+import Servant.API ((:<|>) ((:<|>)),

57+ (:>), AuthProtect,

58+ BasicAuth,

59+ BasicAuthData (..),

60+ Capture,

61+ CaptureAll, Delete,

62+ DeleteNoContent,

63+ EmptyAPI, addHeader,

64+ FormUrlEncoded,

65+ Get, Header,

66+ Headers, JSON,

67+ NoContent (NoContent),

68+ Post, Put, Raw,

69+ QueryFlag,

70+ QueryParam,

71+ QueryParams,

72+ ReqBody,

73+ getHeaders)

5774import Servant.API.Internal.Test.ComprehensiveAPI

5875import Servant.Client

59−import Servant.Client.Generic

60−import qualified Servant.Common.Req as SCR

76+import qualified Servant.Client.Core.Internal.Request as Req

77+import qualified Servant.Client.Core.Internal.Auth as Auth

6178import Servant.Server

6279import Servant.Server.Experimental.Auth

6380

@@ -75,17 +92,16 @@ spec = describe "Servant.Client" $ do

7592

7693-- * test data types

7794

78−data Person = Person {

79− name :: String,

80− age :: Integer

81− }

82− deriving (Eq, Show, Generic)

95+data Person = Person

96+ { _name :: String

97+ , _age :: Integer

98+ } deriving (Eq, Show, Generic)

8399

84100instance ToJSON Person

85101instance FromJSON Person

86102

87−instance ToForm Person where

88−instance FromForm Person where

103+instance ToForm Person

104+instance FromForm Person

89105

90106alice :: Person

91107alice = Person "Alice" 42

@@ -116,22 +132,20 @@ type Api =

116132api :: Proxy Api

117133api = Proxy

118134

119−getGet :: SCR.ClientM Person

120−getDeleteEmpty :: SCR.ClientM NoContent

121−getCapture :: String -> SCR.ClientM Person

122−getCaptureAll :: [String] -> SCR.ClientM [Person]

123−getBody :: Person -> SCR.ClientM Person

124−getQueryParam :: Maybe String -> SCR.ClientM Person

125−getQueryParams :: [String] -> SCR.ClientM [Person]

126−getQueryFlag :: Bool -> SCR.ClientM Bool

127−getRawSuccess :: HTTP.Method

128− -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

129−getRawFailure :: HTTP.Method

130− -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)

135+getGet :: ClientM Person

136+getDeleteEmpty :: ClientM NoContent

137+getCapture :: String -> ClientM Person

138+getCaptureAll :: [String] -> ClientM [Person]

139+getBody :: Person -> ClientM Person

140+getQueryParam :: Maybe String -> ClientM Person

141+getQueryParams :: [String] -> ClientM [Person]

142+getQueryFlag :: Bool -> ClientM Bool

143+getRawSuccess :: HTTP.Method -> ClientM Response

144+getRawFailure :: HTTP.Method -> ClientM Response

131145getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]

132− -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])

133−getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)

134−getDeleteContentType :: SCR.ClientM NoContent

146+ -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])

147+getRespHeaders :: ClientM (Headers TestHeaders Bool)

148+getDeleteContentType :: ClientM NoContent

135149

136150getGet

137151 :<|> getDeleteEmpty

@@ -161,8 +175,8 @@ server = serve api (

161175 Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])

162176 :<|> (\ names -> return (zipWith Person names [0..]))

163177 :<|> return

164− :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")

165− :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")

178+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")

179+ :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")

166180 :<|> (\ a b c d -> return (a, b, c, d))

167181 :<|> (return $ addHeader 1729 $ addHeader "eg2" True)

168182 :<|> return NoContent

@@ -178,9 +192,9 @@ failApi = Proxy

178192

179193failServer :: Application

180194failServer = serve failApi (

181− (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")

182− :<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")

183− :<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

195+ (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")

196+ :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")

197+ :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")

184198 )

185199

186200-- * basic auth stuff

@@ -214,16 +228,16 @@ genAuthAPI :: Proxy GenAuthAPI

214228genAuthAPI = Proxy

215229

216230type instance AuthServerData (AuthProtect "auth-tag") = ()

217−type instance AuthClientData (AuthProtect "auth-tag") = ()

231+type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()

218232

219−genAuthHandler :: AuthHandler Request ()

233+genAuthHandler :: AuthHandler Wai.Request ()

220234genAuthHandler =

221− let handler req = case lookup "AuthHeader" (requestHeaders req) of

235+ let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of

222236 Nothing -> throwError (err401 { errBody = "Missing auth header" })

223237 Just _ -> return ()

224238 in mkAuthHandler handler

225239

226−genAuthServerContext :: Context '[ AuthHandler Request () ]

240+genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]

227241genAuthServerContext = genAuthHandler :. EmptyContext

228242

229243genAuthServer :: Application

@@ -236,11 +250,11 @@ type GenericClientAPI

236250 :<|> Capture "foo" String :> NestedAPI1

237251

238252data GenericClient = GenericClient

239− { getSqr :: Maybe Int -> SCR.ClientM Int

253+ { getSqr :: Maybe Int -> ClientM Int

240254 , mkNestedClient1 :: String -> NestedClient1

241255 } deriving Generic

242256instance SOP.Generic GenericClient

243−instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient

257+instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient

244258

245259type NestedAPI1

246260 = QueryParam "int" Int :> NestedAPI2

@@ -248,21 +262,21 @@ type NestedAPI1

248262

249263data NestedClient1 = NestedClient1

250264 { mkNestedClient2 :: Maybe Int -> NestedClient2

251− , idChar :: Maybe Char -> SCR.ClientM Char

265+ , idChar :: Maybe Char -> ClientM Char

252266 } deriving Generic

253267instance SOP.Generic NestedClient1

254−instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1

268+instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1

255269

256270type NestedAPI2

257271 = "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int

258272 :<|> "void" :> Post '[JSON] ()

259273

260274data NestedClient2 = NestedClient2

261− { getSum :: Int -> Int -> SCR.ClientM Int

262− , doNothing :: SCR.ClientM ()

275+ { getSum :: Int -> Int -> ClientM Int

276+ , doNothing :: ClientM ()

263277 } deriving Generic

264278instance SOP.Generic NestedClient2

265−instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2

279+instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2

266280

267281genericClientServer :: Application

268282genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (

@@ -276,67 +290,70 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (

276290 nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)

277291 nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()

278292

279−{-# NOINLINE manager #-}

280−manager :: C.Manager

281−manager = unsafePerformIO $ C.newManager C.defaultManagerSettings

293+{-# NOINLINE manager' #-}

294+manager' :: C.Manager

295+manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings

296+

297+runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)

298+runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')

282299

283300sucessSpec :: Spec

284301sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

285302

286303 it "Servant.API.Get" $ \(_, baseUrl) -> do

287− (left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice

304+ left show <$> runClient getGet baseUrl `shouldReturn` Right alice

288305

289306 describe "Servant.API.Delete" $ do

290307 it "allows empty content type" $ \(_, baseUrl) -> do

291− (left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent

308+ left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent

292309

293310 it "allows content type" $ \(_, baseUrl) -> do

294− (left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent

311+ left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent

295312

296313 it "Servant.API.Capture" $ \(_, baseUrl) -> do

297− (left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)

314+ left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)

298315

299316 it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do

300317 let expected = [(Person "Paula" 0), (Person "Peta" 1)]

301− (left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected

318+ left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected

302319

303320 it "Servant.API.ReqBody" $ \(_, baseUrl) -> do

304321 let p = Person "Clara" 42

305− (left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p

322+ left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p

306323

307324 it "Servant.API.QueryParam" $ \(_, baseUrl) -> do

308− left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice

309− Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)

310− responseStatus `shouldBe` HTTP.Status 400 "bob not found"

325+ left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice

326+ Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl

327+ responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"

311328

312329 it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do

313− (left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []

314− (left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))

330+ left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []

331+ left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl

315332 `shouldReturn` Right [Person "alice" 0, Person "bob" 1]

316333

317334 context "Servant.API.QueryParam.QueryFlag" $

318335 forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do

319− (left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag

336+ left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag

320337

321338 it "Servant.API.Raw on success" $ \(_, baseUrl) -> do

322− res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)

339+ res <- runClient (getRawSuccess HTTP.methodGet) baseUrl

323340 case res of

324341 Left e -> assertFailure $ show e

325− Right (code, body, ct, _, response) -> do

326− (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")

327− C.responseBody response `shouldBe` body

328− C.responseStatus response `shouldBe` HTTP.ok200

342+ Right r -> do

343+ responseStatusCode r `shouldBe` HTTP.status200

344+ responseBody r `shouldBe` "rawSuccess"

329345

330346 it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do

331− res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)

347+ res <- runClient (getRawFailure HTTP.methodGet) baseUrl

332348 case res of

333349 Right _ -> assertFailure "expected Left, but got Right"

334− Left e -> do

335− Servant.Client.responseStatus e `shouldBe` HTTP.status400

336− Servant.Client.responseBody e `shouldBe` "rawFailure"

350+ Left (FailureResponse r) -> do

351+ responseStatusCode r `shouldBe` HTTP.status400

352+ responseBody r `shouldBe` "rawFailure"

353+ Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e

337354

338355 it "Returns headers appropriately" $ \(_, baseUrl) -> do

339− res <- runClientM getRespHeaders (ClientEnv manager baseUrl)

356+ res <- runClient getRespHeaders baseUrl

340357 case res of

341358 Left e -> assertFailure $ show e

342359 Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]

@@ -345,7 +362,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do

345362 it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->

346363 property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->

347364 ioProperty $ do

348− result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)

365+ result <- left show <$> runClient (getMultiple cap num flag body) baseUrl

349366 return $

350367 result === Right (cap, num, flag, body)

351368

@@ -357,10 +374,10 @@ wrappedApiSpec = describe "error status codes" $ do

357374 let test :: (WrappedApi, String) -> Spec

358375 test (WrappedApi api, desc) =

359376 it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do

360− let getResponse :: SCR.ClientM ()

377+ let getResponse :: ClientM ()

361378 getResponse = client api

362− Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)

363− responseStatus `shouldBe` (HTTP.Status 500 "error message")

379+ Left (FailureResponse r) <- runClient getResponse baseUrl

380+ responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")

364381 in mapM_ test $

365382 (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :

366383 (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :

@@ -374,42 +391,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do

374391 context "client returns errors appropriately" $ do

375392 it "reports FailureResponse" $ \(_, baseUrl) -> do

376393 let (_ :<|> getDeleteEmpty :<|> _) = client api

377− Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)

394+ Left res <- runClient getDeleteEmpty baseUrl

378395 case res of

379− FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return ()

396+ FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()

380397 _ -> fail $ "expected 404 response, but got " <> show res

381398

382399 it "reports DecodeFailure" $ \(_, baseUrl) -> do

383400 let (_ :<|> _ :<|> getCapture :<|> _) = client api

384− Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)

401+ Left res <- runClient (getCapture "foo") baseUrl

385402 case res of

386− DecodeFailure _ ("application/json") _ -> return ()

403+ DecodeFailure _ _ -> return ()

387404 _ -> fail $ "expected DecodeFailure, but got " <> show res

388405

389406 it "reports ConnectionError" $ \_ -> do

390407 let (getGetWrongHost :<|> _) = client api

391− Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))

408+ Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")

392409 case res of

393410 ConnectionError _ -> return ()

394411 _ -> fail $ "expected ConnectionError, but got " <> show res

395412

396413 it "reports UnsupportedContentType" $ \(_, baseUrl) -> do

397414 let (getGet :<|> _ ) = client api

398− Left res <- runClientM getGet (ClientEnv manager baseUrl)

415+ Left res <- runClient getGet baseUrl

399416 case res of

400417 UnsupportedContentType ("application/octet-stream") _ -> return ()

401418 _ -> fail $ "expected UnsupportedContentType, but got " <> show res

402419

403420 it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do

404421 let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api

405− Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)

422+ Left res <- runClient (getBody alice) baseUrl

406423 case res of

407− InvalidContentTypeHeader "fooooo" _ -> return ()

424+ InvalidContentTypeHeader _ -> return ()

408425 _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res

409426

410427data WrappedApi where

411428 WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,

412− HasClient api, Client api ~ SCR.ClientM ()) =>

429+ HasClient ClientM api, Client ClientM api ~ ClientM ()) =>

413430 Proxy api -> WrappedApi

414431

415432basicAuthSpec :: Spec

@@ -419,15 +436,15 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d

419436 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

420437 let getBasic = client basicAuthAPI

421438 let basicAuthData = BasicAuthData "servant" "server"

422− (left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice

439+ left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice

423440

424441 context "Authentication is rejected when requests are not authenticated properly" $ do

425442

426443 it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do

427444 let getBasic = client basicAuthAPI

428445 let basicAuthData = BasicAuthData "not" "password"

429− Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)

430− responseStatus `shouldBe` HTTP.Status 403 "Forbidden"

446+ Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl

447+ responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"

431448

432449genAuthSpec :: Spec

433450genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

@@ -435,16 +452,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do

435452

436453 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

437454 let getProtected = client genAuthAPI

438− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)

439− (left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice

455+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)

456+ left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice

440457

441458 context "Authentication is rejected when requests are not authenticated properly" $ do

442459

443460 it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do

444461 let getProtected = client genAuthAPI

445− let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)

446− Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)

447− responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")

462+ let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)

463+ Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl

464+ responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")

448465

449466genericClientSpec :: Spec

450467genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do

@@ -454,13 +471,13 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa

454471 NestedClient1{..} = mkNestedClient1 "example"

455472 NestedClient2{..} = mkNestedClient2 (Just 42)

456473

457− it "works for top-level client function" $ \(_, baseUrl) -> do

458− (left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25

474+ it "works for top-level client inClientM function" $ \(_, baseUrl) -> do

475+ left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25

459476

460477 it "works for nested clients" $ \(_, baseUrl) -> do

461− (left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c'

462− (left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7

463− (left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right ()

478+ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'

479+ left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7

480+ left show <$> runClient doNothing baseUrl `shouldReturn` Right ()

464481

465482-- * utils

466483

stack-ghc-7.10.3.yaml+1

@@ -2,6 +2,7 @@ flags: {}

22packages:

33- servant/

44- servant-client/

5+- servant-client-core/

56- servant-docs/

67- servant-foreign/

78- servant-server/

stack-ghc-7.8.4.yaml+2

@@ -2,6 +2,7 @@ flags: {}

22packages:

33- servant/

44- servant-client/

5+- servant-client-core/

56- servant-docs/

67- servant-foreign/

78- servant-server/

@@ -19,6 +20,7 @@ extra-deps:

1920- hspec-expectations-0.8.2

2021- hspec-wai-0.8.0

2122- http-api-data-0.3.6

23+- http-client-0.4.30

2224- natural-transformation-0.4

2325- primitive-0.6.1.0

2426- servant-js-0.9.3

stack-ghc-8.2.1.yaml+1

@@ -1,6 +1,7 @@

11resolver: nightly-2017-09-01

22packages:

33- servant-client/

4+- servant-client-core/

45- servant-docs/

56- servant-foreign/

67- servant-server/

stack.yaml+1

@@ -2,6 +2,7 @@ resolver: nightly-2017-04-01

22packages:

33- servant/

44- servant-client/

5+- servant-client-core/

56- servant-docs/

67- servant-foreign/

78- servant-server/