Merge pull request #803 from haskell-servant/pr800
Factor out servant-client-core
This commit is contained in:
Julian Arni
GitHub
commit
28fe7a0d0f
|
|
@ -128,15 +128,15 @@ That's it. Let's now write some code that uses our client functions.
|
|||
``` haskell
|
||||
queries :: ClientM (Position, HelloMessage, Email)
|
||||
queries = do
|
||||
pos <- position 10 10
|
||||
message <- hello (Just "servant")
|
||||
pos <- position 10 10
|
||||
message <- hello (Just "servant")
|
||||
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
|
||||
return (pos, message, em)
|
||||
|
||||
run :: IO ()
|
||||
run = do
|
||||
manager <- newManager defaultManagerSettings
|
||||
res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 ""))
|
||||
manager' <- newManager defaultManagerSettings
|
||||
res <- runClientM queries (ClientEnv manager' (BaseUrl Http "localhost" 8081 ""))
|
||||
case res of
|
||||
Left err -> putStrLn $ "Error: " ++ show err
|
||||
Right (pos, message, em) -> do
|
||||
|
|
|
|||
6
servant-client-core/CHANGELOG.md
Normal file
6
servant-client-core/CHANGELOG.md
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
# Revision history for servant-client-core
|
||||
|
||||
## 0.12 -- YYYY-mm-dd
|
||||
|
||||
* First version. Factored out of servant-client all the functionality that was
|
||||
independent of the http-client backend.
|
||||
30
servant-client-core/LICENSE
Normal file
30
servant-client-core/LICENSE
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2017, Servant Contributors
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Servant Contributors nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
30
servant-client-core/README.md
Normal file
30
servant-client-core/README.md
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
# servant-client-core
|
||||
|
||||
|
||||
|
||||
HTTP-client-agnostic client functions for servant APIs.
|
||||
|
||||
This library should mainly be of interest to backend- and combinator-writers.
|
||||
|
||||
## For backend-writers
|
||||
|
||||
If you are creating a new backend, you'll need to:
|
||||
|
||||
1. Define a `RunClient` instance for your datatype (call it `MyMonad`)
|
||||
2. Define a `ClientLike` instance. This will look like:
|
||||
|
||||
``` haskell
|
||||
instance ClientLike (MyMonad a) (MyMonad a) where
|
||||
mkClient = id
|
||||
```
|
||||
|
||||
3. Re-export the module Servant.Client.Core.Reexport so that your end-users
|
||||
can be blissfully unaware of 'servant-client-core', and so each
|
||||
backend-package comes closer to the warm hearth of the drop-in-replacement
|
||||
equivalence class.
|
||||
|
||||
## For combinator-writers
|
||||
|
||||
You'll need to define a new `HasClient` instance for your combinator. There are
|
||||
plenty of examples to guide you in the
|
||||
[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module.
|
||||
2
servant-client-core/Setup.hs
Normal file
2
servant-client-core/Setup.hs
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
8
servant-client-core/include/overlapping-compat.h
Normal file
8
servant-client-core/include/overlapping-compat.h
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
#if __GLASGOW_HASKELL__ >= 710
|
||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
||||
#else
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#define OVERLAPPABLE_
|
||||
#define OVERLAPPING_
|
||||
#endif
|
||||
74
servant-client-core/servant-client-core.cabal
Normal file
74
servant-client-core/servant-client-core.cabal
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
name: servant-client-core
|
||||
version: 0.11
|
||||
synopsis: Core functionality and class for client function generation for servant APIs
|
||||
description:
|
||||
This library provides backend-agnostic generation of client functions. For
|
||||
more information, see the README.
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
cabal-version: >=1.10
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant.Client.Core
|
||||
Servant.Client.Core.Reexport
|
||||
Servant.Client.Core.Internal.Auth
|
||||
Servant.Client.Core.Internal.BaseUrl
|
||||
Servant.Client.Core.Internal.BasicAuth
|
||||
Servant.Client.Core.Internal.Generic
|
||||
Servant.Client.Core.Internal.HasClient
|
||||
Servant.Client.Core.Internal.Request
|
||||
Servant.Client.Core.Internal.RunClient
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
, base-compat >= 0.9.1 && < 0.10
|
||||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, containers >= 0.5 && < 0.6
|
||||
, exceptions >= 0.8 && < 0.9
|
||||
, generics-sop >= 0.1.0.0 && < 0.4
|
||||
, http-api-data >= 0.3.6 && < 0.4
|
||||
, http-media >= 0.6.2 && < 0.8
|
||||
, http-types >= 0.8.6 && < 0.10
|
||||
, mtl >= 2.1 && < 2.3
|
||||
, network-uri >= 2.6 && < 2.7
|
||||
, safe >= 0.3.9 && < 0.4
|
||||
, servant == 0.11.*
|
||||
, text >= 1.2 && < 1.3
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >=0.16.2.2 && <0.19
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
include-dirs: include
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
build-depends:
|
||||
base
|
||||
, base-compat
|
||||
, deepseq
|
||||
, servant-client-core
|
||||
, hspec == 2.*
|
||||
, QuickCheck >= 2.7 && < 2.11
|
||||
other-modules:
|
||||
Servant.Client.Core.Internal.BaseUrlSpec
|
||||
65
servant-client-core/src/Servant/Client/Core.hs
Normal file
65
servant-client-core/src/Servant/Client/Core.hs
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
-- | This module provides backend-agnostic functionality for generating clients
|
||||
-- from @servant@ APIs. By "backend," we mean something that concretely
|
||||
-- executes the request, such as:
|
||||
--
|
||||
-- * The @http-client@ library
|
||||
-- * The @haxl@ library
|
||||
-- * GHCJS via FFI
|
||||
--
|
||||
-- etc.
|
||||
--
|
||||
-- Each backend is encapsulated in a monad that is an instance of the
|
||||
-- 'RunClient' class.
|
||||
--
|
||||
-- This library is primarily of interest to backend-writers and
|
||||
-- combinator-writers. For more information, see the README.md
|
||||
module Servant.Client.Core
|
||||
(
|
||||
-- * Client generation
|
||||
clientIn
|
||||
, HasClient(..)
|
||||
|
||||
-- * Request
|
||||
, Request
|
||||
, RequestF(..)
|
||||
, defaultRequest
|
||||
, RequestBody(..)
|
||||
|
||||
-- * Authentication
|
||||
, mkAuthenticatedRequest
|
||||
, basicAuthReq
|
||||
, AuthenticatedRequest(..)
|
||||
, AuthClientData
|
||||
|
||||
-- * Generic Client
|
||||
, ClientLike(..)
|
||||
, genericMkClientL
|
||||
, genericMkClientP
|
||||
, ServantError(..)
|
||||
, EmptyClient(..)
|
||||
|
||||
|
||||
-- * Response
|
||||
, Response(..)
|
||||
, RunClient(..)
|
||||
, module Servant.Client.Core.Internal.BaseUrl
|
||||
|
||||
-- * Writing HasClient instances
|
||||
-- | These functions need not be re-exported by backend libraries.
|
||||
, addHeader
|
||||
, appendToQueryString
|
||||
, appendToPath
|
||||
, setRequestBodyLBS
|
||||
, setRequestBody
|
||||
) where
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
|
||||
InvalidBaseUrlException,
|
||||
Scheme (..),
|
||||
parseBaseUrl,
|
||||
showBaseUrl)
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.RunClient
|
||||
|
|
@ -1,16 +1,12 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | Authentication for clients
|
||||
|
||||
module Servant.Client.Experimental.Auth (
|
||||
AuthenticateReq(AuthenticateReq, unAuthReq)
|
||||
, AuthClientData
|
||||
, mkAuthenticateReq
|
||||
) where
|
||||
module Servant.Client.Core.Internal.Auth where
|
||||
|
||||
import Servant.Common.Req (Req)
|
||||
import Servant.Client.Core.Internal.Request (Request)
|
||||
|
||||
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
||||
-- to provide the client with some data used to add authentication data
|
||||
|
|
@ -24,13 +20,13 @@ type family AuthClientData a :: *
|
|||
-- data to a request
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
newtype AuthenticateReq a =
|
||||
AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }
|
||||
newtype AuthenticatedRequest a =
|
||||
AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) }
|
||||
|
||||
-- | Handy helper to avoid wrapping datatypes in tuples everywhere.
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
mkAuthenticateReq :: AuthClientData a
|
||||
-> (AuthClientData a -> Req -> Req)
|
||||
-> AuthenticateReq a
|
||||
mkAuthenticateReq val func = AuthenticateReq (val, func)
|
||||
mkAuthenticatedRequest :: AuthClientData a
|
||||
-> (AuthClientData a -> Request -> Request)
|
||||
-> AuthenticatedRequest a
|
||||
mkAuthenticatedRequest val func = AuthenticatedRequest (val, func)
|
||||
|
|
@ -1,21 +1,13 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Servant.Common.BaseUrl (
|
||||
-- * types
|
||||
BaseUrl (..)
|
||||
, InvalidBaseUrlException
|
||||
, Scheme (..)
|
||||
-- * functions
|
||||
, parseBaseUrl
|
||||
, showBaseUrl
|
||||
) where
|
||||
module Servant.Client.Core.Internal.BaseUrl where
|
||||
|
||||
import Control.Monad.Catch (Exception, MonadThrow, throwM)
|
||||
import Data.List
|
||||
import Data.Typeable
|
||||
import GHC.Generics
|
||||
import Network.URI hiding (path)
|
||||
import Network.URI hiding (path)
|
||||
import Safe
|
||||
import Text.Read
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
-- | Basic Authentication for clients
|
||||
|
||||
module Servant.Client.Core.Internal.BasicAuth where
|
||||
|
||||
import Data.ByteString.Base64 (encode)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
|
||||
import Servant.Client.Core.Internal.Request (Request, addHeader)
|
||||
|
||||
-- | Authenticate a request using Basic Authentication
|
||||
basicAuthReq :: BasicAuthData -> Request -> Request
|
||||
basicAuthReq (BasicAuthData user pass) req =
|
||||
let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
|
||||
in addHeader "Authorization" authText req
|
||||
|
|
@ -10,15 +10,10 @@
|
|||
|
||||
#include "overlapping-compat.h"
|
||||
|
||||
module Servant.Client.Generic
|
||||
( ClientLike(..)
|
||||
, genericMkClientL
|
||||
, genericMkClientP
|
||||
) where
|
||||
module Servant.Client.Core.Internal.Generic where
|
||||
|
||||
import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
|
||||
import Servant.API ((:<|>)(..))
|
||||
import Servant.Client (ClientM)
|
||||
|
||||
-- | This class allows us to match client structure with client functions
|
||||
-- produced with 'client' without explicit pattern-matching.
|
||||
|
|
@ -111,9 +106,6 @@ instance ClientLike client custom
|
|||
=> ClientLike (a -> client) (a -> custom) where
|
||||
mkClient c = mkClient . c
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
-- | Match client structure with client functions, regarding left-nested API clients
|
||||
-- as separate data structures.
|
||||
class GClientLikeP client xs where
|
||||
|
|
@ -0,0 +1,541 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
module Servant.Client.Core.Internal.HasClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (foldl')
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Sequence (fromList)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (pack)
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Servant.API ((:<|>) ((:<|>)), (:>),
|
||||
AuthProtect, BasicAuth,
|
||||
BasicAuthData,
|
||||
BuildHeadersTo (..),
|
||||
Capture, CaptureAll,
|
||||
Description, EmptyAPI,
|
||||
Header, Headers (..),
|
||||
HttpVersion, IsSecure,
|
||||
MimeRender (mimeRender),
|
||||
MimeUnrender (mimeUnrender),
|
||||
NoContent (NoContent),
|
||||
QueryFlag, QueryParam,
|
||||
QueryParams, Raw,
|
||||
ReflectMethod (..),
|
||||
RemoteHost, ReqBody,
|
||||
Summary, ToHttpApiData,
|
||||
Vault, Verb,
|
||||
WithNamedContext,
|
||||
contentType,
|
||||
getHeadersHList,
|
||||
getResponse,
|
||||
toQueryParam,
|
||||
toUrlPiece)
|
||||
import Servant.API.ContentTypes (contentTypes)
|
||||
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.RunClient
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
-- | 'clientIn' allows you to produce operations to query an API from a client
|
||||
-- within a 'RunClient' monad.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > clientM :: Proxy ClientM
|
||||
-- > clientM = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
|
||||
clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
|
||||
clientIn p pm = clientWithRoute pm p defaultRequest
|
||||
|
||||
|
||||
-- | This class lets us define how each API combinator influences the creation
|
||||
-- of an HTTP request.
|
||||
--
|
||||
-- Unless you are writing a new backend for @servant-client-core@ or new
|
||||
-- combinators that you want to support client-generation, you can ignore this
|
||||
-- class.
|
||||
class RunClient m => HasClient m api where
|
||||
type Client (m :: * -> *) (api :: *) :: *
|
||||
clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
|
||||
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
-- one function for querying @a@ and another one for querying @b@,
|
||||
-- stitching them together with ':<|>', which really is just like a pair.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
|
||||
type Client m (a :<|> b) = Client m a :<|> Client m b
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy a) req :<|>
|
||||
clientWithRoute pm (Proxy :: Proxy b) req
|
||||
|
||||
-- | Singleton type representing a client for an empty API.
|
||||
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
|
||||
|
||||
-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
|
||||
--
|
||||
-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "nothing" :> EmptyAPI
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > (getAllBooks :<|> EmptyClient) = client myApi
|
||||
instance RunClient m => HasClient m EmptyAPI where
|
||||
type Client m EmptyAPI = EmptyClient
|
||||
clientWithRoute _pm Proxy _ = EmptyClient
|
||||
|
||||
-- | If you use a 'Capture' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Capture'.
|
||||
-- That function will take care of inserting a textual representation
|
||||
-- of this value at the right place in the request path.
|
||||
--
|
||||
-- You can control how values for this type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: Text -> ClientM Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (Capture capture a :> api) where
|
||||
|
||||
type Client m (Capture capture a :> api) =
|
||||
a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req val =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = (toUrlPiece val)
|
||||
|
||||
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take an
|
||||
-- additional argument of a list of the type specified by your
|
||||
-- 'CaptureAll'. That function will take care of inserting a textual
|
||||
-- representation of this value at the right place in the request
|
||||
-- path.
|
||||
--
|
||||
-- You can control how these values are turned into text by specifying
|
||||
-- a 'ToHttpApiData' instance of your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
|
||||
-- >
|
||||
-- > myApi :: Proxy
|
||||
-- > myApi = Proxy
|
||||
--
|
||||
-- > getSourceFile :: [Text] -> ClientM SourceFile
|
||||
-- > getSourceFile = client myApi
|
||||
-- > -- then you can use "getSourceFile" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
|
||||
=> HasClient m (CaptureAll capture a :> sublayout) where
|
||||
|
||||
type Client m (CaptureAll capture a :> sublayout) =
|
||||
[a] -> Client m sublayout
|
||||
|
||||
clientWithRoute pm Proxy req vals =
|
||||
clientWithRoute pm (Proxy :: Proxy sublayout)
|
||||
(foldl' (flip appendToPath) req ps)
|
||||
|
||||
where ps = map (toUrlPiece) vals
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
-- Note [Non-Empty Content Types]
|
||||
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
) => HasClient m (Verb method status cts' a) where
|
||||
type Client m (Verb method status cts' a) = m a
|
||||
clientWithRoute _pm Proxy req = do
|
||||
response <- runRequest req
|
||||
{ requestAccept = fromList $ toList accept
|
||||
, requestMethod = method
|
||||
}
|
||||
response `decodedAs` (Proxy :: Proxy ct)
|
||||
where
|
||||
accept = contentTypes (Proxy :: Proxy ct)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
( RunClient m, ReflectMethod method
|
||||
) => HasClient m (Verb method status cts NoContent) where
|
||||
type Client m (Verb method status cts NoContent)
|
||||
= m NoContent
|
||||
clientWithRoute _pm Proxy req = do
|
||||
_response <- runRequest req { requestMethod = method }
|
||||
return NoContent
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
-- Note [Non-Empty Content Types]
|
||||
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
|
||||
, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
) => HasClient m (Verb method status cts' (Headers ls a)) where
|
||||
type Client m (Verb method status cts' (Headers ls a))
|
||||
= m (Headers ls a)
|
||||
clientWithRoute _pm Proxy req = do
|
||||
response <- runRequest req
|
||||
{ requestMethod = method
|
||||
, requestAccept = fromList $ toList accept
|
||||
}
|
||||
case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
|
||||
Left err -> throwServantError $ DecodeFailure (pack err) response
|
||||
Right val -> return $ Headers
|
||||
{ getResponse = val
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||
}
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
accept = contentTypes (Proxy :: Proxy ct)
|
||||
|
||||
instance OVERLAPPING_
|
||||
( RunClient m, BuildHeadersTo ls, ReflectMethod method
|
||||
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
|
||||
type Client m (Verb method status cts (Headers ls NoContent))
|
||||
= m (Headers ls NoContent)
|
||||
clientWithRoute _pm Proxy req = do
|
||||
let method = reflectMethod (Proxy :: Proxy method)
|
||||
response <- runRequest req { requestMethod = method }
|
||||
return $ Headers { getResponse = NoContent
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||
}
|
||||
|
||||
|
||||
-- | If you use a 'Header' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Header',
|
||||
-- wrapped in Maybe.
|
||||
--
|
||||
-- That function will take care of encoding this argument as Text
|
||||
-- in the request headers.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToHttpApiData' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > newtype Referer = Referer { referrer :: Text }
|
||||
-- > deriving (Eq, Show, Generic, ToHttpApiData)
|
||||
-- >
|
||||
-- > -- GET /view-my-referer
|
||||
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > viewReferer :: Maybe Referer -> ClientM Book
|
||||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (Header sym a :> api) where
|
||||
|
||||
type Client m (Header sym a :> api) =
|
||||
Maybe a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req mval =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(\value -> addHeader hname value req)
|
||||
mval
|
||||
)
|
||||
|
||||
where hname = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
|
||||
-- functions.
|
||||
instance HasClient m api
|
||||
=> HasClient m (HttpVersion :> api) where
|
||||
|
||||
type Client m (HttpVersion :> api) =
|
||||
Client m api
|
||||
|
||||
clientWithRoute pm Proxy =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
-- | Ignore @'Summary'@ in client functions.
|
||||
instance HasClient m api => HasClient m (Summary desc :> api) where
|
||||
type Client m (Summary desc :> api) = Client m api
|
||||
|
||||
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
-- | Ignore @'Description'@ in client functions.
|
||||
instance HasClient m api => HasClient m (Description desc :> api) where
|
||||
type Client m (Description desc :> api) = Client m api
|
||||
|
||||
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'QueryParam',
|
||||
-- enclosed in Maybe.
|
||||
--
|
||||
-- If you give Nothing, nothing will be added to the query string.
|
||||
--
|
||||
-- If you give a non-'Nothing' value, this function will take care
|
||||
-- of inserting a textual representation of this value in the query string.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (QueryParam sym a :> api) where
|
||||
|
||||
type Client m (QueryParam sym a :> api) =
|
||||
Maybe a -> Client m api
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute pm Proxy req mparam =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(flip (appendToQueryString pname) req . Just)
|
||||
mparamText
|
||||
)
|
||||
|
||||
where pname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
mparamText = fmap toQueryParam mparam
|
||||
|
||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument, a list of values of the type specified
|
||||
-- by your 'QueryParams'.
|
||||
--
|
||||
-- If you give an empty list, nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will take care
|
||||
-- of inserting a textual representation of your values in the query string,
|
||||
-- under the same query string parameter name.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (QueryParams sym a :> api) where
|
||||
|
||||
type Client m (QueryParams sym a :> api) =
|
||||
[a] -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req paramlist =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
|
||||
req
|
||||
paramlist'
|
||||
)
|
||||
|
||||
where pname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
paramlist' = map (Just . toQueryParam) paramlist
|
||||
|
||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional 'Bool' argument.
|
||||
--
|
||||
-- If you give 'False', nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will insert a value-less query string
|
||||
-- parameter under the name associated to your 'QueryFlag'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> ClientM [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient m api)
|
||||
=> HasClient m (QueryFlag sym :> api) where
|
||||
|
||||
type Client m (QueryFlag sym :> api) =
|
||||
Bool -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req flag =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(if flag
|
||||
then appendToQueryString paramname Nothing req
|
||||
else req
|
||||
)
|
||||
|
||||
where paramname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
instance RunClient m => HasClient m Raw where
|
||||
type Client m Raw
|
||||
= H.Method -> m Response
|
||||
|
||||
clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
|
||||
clientWithRoute _pm Proxy req httpMethod = do
|
||||
runRequest req { requestMethod = httpMethod }
|
||||
|
||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'ReqBody'.
|
||||
-- That function will take care of encoding this argument as JSON and
|
||||
-- of using it as the request body.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > addBook :: Book -> ClientM Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient m api)
|
||||
=> HasClient m (ReqBody (ct ': cts) a :> api) where
|
||||
|
||||
type Client m (ReqBody (ct ': cts) a :> api) =
|
||||
a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req body =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(let ctProxy = Proxy :: Proxy ct
|
||||
in setRequestBodyLBS (mimeRender ctProxy body)
|
||||
-- We use first contentType from the Accept list
|
||||
(contentType ctProxy)
|
||||
req
|
||||
)
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
|
||||
type Client m (path :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = pack $ symbolVal (Proxy :: Proxy path)
|
||||
|
||||
instance HasClient m api => HasClient m (Vault :> api) where
|
||||
type Client m (Vault :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient m api => HasClient m (RemoteHost :> api) where
|
||||
type Client m (RemoteHost :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient m api => HasClient m (IsSecure :> api) where
|
||||
type Client m (IsSecure :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient m subapi =>
|
||||
HasClient m (WithNamedContext name context subapi) where
|
||||
|
||||
type Client m (WithNamedContext name context subapi) = Client m subapi
|
||||
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
|
||||
|
||||
instance ( HasClient m api
|
||||
) => HasClient m (AuthProtect tag :> api) where
|
||||
type Client m (AuthProtect tag :> api)
|
||||
= AuthenticatedRequest (AuthProtect tag) -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
|
||||
clientWithRoute pm (Proxy :: Proxy api) (func val req)
|
||||
|
||||
-- * Basic Authentication
|
||||
|
||||
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
|
||||
type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req val =
|
||||
clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
|
||||
|
||||
|
||||
{- Note [Non-Empty Content Types]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Rather than have
|
||||
|
||||
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
|
||||
|
||||
It may seem to make more sense to have:
|
||||
|
||||
instance (...) => ... (ct ': cts) ...
|
||||
|
||||
But this means that if another instance exists that does *not* require
|
||||
non-empty lists, but is otherwise more specific, no instance will be overall
|
||||
more specific. This in turn generally means adding yet another instance (one
|
||||
for empty and one for non-empty lists).
|
||||
-}
|
||||
117
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
Normal file
117
servant-client-core/src/Servant/Client/Core/Internal/Request.hs
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Servant.Client.Core.Internal.Request where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad.Catch (Exception)
|
||||
import qualified Data.ByteString.Builder as Builder
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Semigroup ((<>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Media (MediaType)
|
||||
import Network.HTTP.Types (Header, HeaderName, HttpVersion,
|
||||
Method, QueryItem, Status, http11,
|
||||
methodGet)
|
||||
import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
|
||||
toHeader)
|
||||
|
||||
-- | A type representing possible errors in a request
|
||||
--
|
||||
-- Note that this type substantially changed in 0.12.
|
||||
data ServantError =
|
||||
-- | The server returned an error response
|
||||
FailureResponse Response
|
||||
-- | The body could not be decoded at the expected type
|
||||
| DecodeFailure Text Response
|
||||
-- | The content-type of the response is not supported
|
||||
| UnsupportedContentType MediaType Response
|
||||
-- | The content-type header is invalid
|
||||
| InvalidContentTypeHeader Response
|
||||
-- | There was a connection error, and no response was received
|
||||
| ConnectionError Text
|
||||
deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
instance Exception ServantError
|
||||
|
||||
data RequestF a = Request
|
||||
{ requestPath :: a
|
||||
, requestQueryString :: Seq.Seq QueryItem
|
||||
, requestBody :: Maybe (RequestBody, MediaType)
|
||||
, requestAccept :: Seq.Seq MediaType
|
||||
, requestHeaders :: Seq.Seq Header
|
||||
, requestHttpVersion :: HttpVersion
|
||||
, requestMethod :: Method
|
||||
} deriving (Eq, Show, Functor, Generic, Typeable)
|
||||
|
||||
type Request = RequestF Builder.Builder
|
||||
|
||||
-- | The request body. Currently only lazy ByteStrings are supported.
|
||||
newtype RequestBody = RequestBodyLBS LBS.ByteString
|
||||
deriving (Eq, Ord, Read, Show, Typeable)
|
||||
|
||||
data Response = Response
|
||||
{ responseStatusCode :: Status
|
||||
, responseBody :: LBS.ByteString
|
||||
, responseHeaders :: Seq.Seq Header
|
||||
, responseHttpVersion :: HttpVersion
|
||||
} deriving (Eq, Show, Generic, Typeable)
|
||||
|
||||
-- A GET request to the top-level path
|
||||
defaultRequest :: Request
|
||||
defaultRequest = Request
|
||||
{ requestPath = ""
|
||||
, requestQueryString = Seq.empty
|
||||
, requestBody = Nothing
|
||||
, requestAccept = Seq.empty
|
||||
, requestHeaders = Seq.empty
|
||||
, requestHttpVersion = http11
|
||||
, requestMethod = methodGet
|
||||
}
|
||||
|
||||
appendToPath :: Text -> Request -> Request
|
||||
appendToPath p req
|
||||
= req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p }
|
||||
|
||||
appendToQueryString :: Text -- ^ param name
|
||||
-> Maybe Text -- ^ param value
|
||||
-> Request
|
||||
-> Request
|
||||
appendToQueryString pname pvalue req
|
||||
= req { requestQueryString = requestQueryString req
|
||||
Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}
|
||||
|
||||
addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request
|
||||
addHeader name val req
|
||||
= req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)}
|
||||
|
||||
-- | Set body and media type of the request being constructed.
|
||||
--
|
||||
-- The body is set to the given bytestring using the 'RequestBodyLBS'
|
||||
-- constructor.
|
||||
--
|
||||
-- @since 0.12
|
||||
--
|
||||
setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request
|
||||
setRequestBodyLBS b t req
|
||||
= req { requestBody = Just (RequestBodyLBS b, t) }
|
||||
|
||||
-- | Set body and media type of the request being constructed.
|
||||
--
|
||||
-- @since 0.12
|
||||
--
|
||||
setRequestBody :: RequestBody -> MediaType -> Request -> Request
|
||||
setRequestBody b t req = req { requestBody = Just (b, t) }
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Types for possible backends to run client-side `Request` queries
|
||||
module Servant.Client.Core.Internal.RunClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Proxy (Proxy)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Media (MediaType, matches,
|
||||
parseAccept, (//))
|
||||
import Servant.API (MimeUnrender,
|
||||
contentTypes,
|
||||
mimeUnrender)
|
||||
import Servant.Client.Core.Internal.Request (Request, Response (..),
|
||||
ServantError (..))
|
||||
|
||||
class (Monad m) => RunClient m where
|
||||
-- | How to make a request.
|
||||
runRequest :: Request -> m Response
|
||||
throwServantError :: ServantError -> m a
|
||||
catchServantError :: m a -> (ServantError -> m a) -> m a
|
||||
|
||||
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
||||
checkContentTypeHeader response =
|
||||
case lookup "Content-Type" $ toList $ responseHeaders response of
|
||||
Nothing -> return $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwServantError $ InvalidContentTypeHeader response
|
||||
Just t' -> return t'
|
||||
|
||||
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
||||
=> Response -> Proxy ct -> m a
|
||||
decodedAs response contentType = do
|
||||
responseContentType <- checkContentTypeHeader response
|
||||
unless (any (matches responseContentType) accept) $
|
||||
throwServantError $ UnsupportedContentType responseContentType response
|
||||
case mimeUnrender contentType $ responseBody response of
|
||||
Left err -> throwServantError $ DecodeFailure (T.pack err) response
|
||||
Right val -> return val
|
||||
where
|
||||
accept = toList $ contentTypes contentType
|
||||
30
servant-client-core/src/Servant/Client/Core/Reexport.hs
Normal file
30
servant-client-core/src/Servant/Client/Core/Reexport.hs
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
-- | This module is a utility for @servant-client-core@ backend writers. It
|
||||
-- contains all the functionality from @servant-client-core@ that should be
|
||||
-- re-exported.
|
||||
module Servant.Client.Core.Reexport
|
||||
(
|
||||
-- * HasClient
|
||||
HasClient(..)
|
||||
-- * Response (for @Raw@)
|
||||
, Response(..)
|
||||
|
||||
-- * Generic Client
|
||||
, ClientLike(..)
|
||||
, genericMkClientL
|
||||
, genericMkClientP
|
||||
, ServantError(..)
|
||||
, EmptyClient(..)
|
||||
|
||||
-- * BaseUrl
|
||||
, BaseUrl(..)
|
||||
, Scheme(..)
|
||||
, showBaseUrl
|
||||
, parseBaseUrl
|
||||
, InvalidBaseUrlException
|
||||
) where
|
||||
|
||||
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.Request
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Common.BaseUrlSpec where
|
||||
module Servant.Client.Core.Internal.BaseUrlSpec (spec) where
|
||||
|
||||
|
||||
import Control.DeepSeq
|
||||
import Prelude ()
|
||||
|
|
@ -7,7 +8,7 @@ import Prelude.Compat
|
|||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
|
|
@ -78,6 +79,3 @@ instance Arbitrary BaseUrl where
|
|||
(1, choose (1, 20000)) :
|
||||
[]
|
||||
pathGen = listOf1 . elements $ letters
|
||||
|
||||
isLeft :: Either a b -> Bool
|
||||
isLeft = either (const True) (const False)
|
||||
1
servant-client-core/test/Spec.hs
Normal file
1
servant-client-core/test/Spec.hs
Normal file
|
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
|
|
@ -12,7 +12,7 @@ license: BSD3
|
|||
license-file: LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
|
||||
category: Servant, Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
|
|
@ -30,39 +30,27 @@ source-repository head
|
|||
library
|
||||
exposed-modules:
|
||||
Servant.Client
|
||||
Servant.Client.Generic
|
||||
Servant.Client.Experimental.Auth
|
||||
Servant.Common.BaseUrl
|
||||
Servant.Common.BasicAuth
|
||||
Servant.Common.Req
|
||||
Servant.Client.Internal.HttpClient
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
, base-compat >= 0.9.1 && < 0.10
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, aeson >= 0.7 && < 1.3
|
||||
, attoparsec >= 0.12 && < 0.14
|
||||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, exceptions >= 0.8 && < 0.9
|
||||
, generics-sop >= 0.1.0.0 && < 0.4
|
||||
, http-api-data >= 0.3.6 && < 0.4
|
||||
, http-client >= 0.4.18.1 && < 0.6
|
||||
, containers >= 0.5 && < 0.6
|
||||
, http-client >= 0.4.30 && < 0.6
|
||||
, http-client-tls >= 0.2.2 && < 0.4
|
||||
, http-media >= 0.6.2 && < 0.8
|
||||
, http-types >= 0.8.6 && < 0.10
|
||||
, exceptions >= 0.8 && < 0.9
|
||||
, monad-control >= 1.0.0.4 && < 1.1
|
||||
, network-uri >= 2.6 && < 2.7
|
||||
, safe >= 0.3.9 && < 0.4
|
||||
, mtl >= 2.1 && < 2.3
|
||||
, semigroupoids >= 4.3 && < 5.3
|
||||
, servant == 0.11.*
|
||||
, string-conversions >= 0.3 && < 0.5
|
||||
, servant-client-core == 0.11.*
|
||||
, text >= 1.2 && < 1.3
|
||||
, transformers >= 0.3 && < 0.6
|
||||
, transformers-base >= 0.4.4 && < 0.5
|
||||
, transformers-compat >= 0.4 && < 0.6
|
||||
, mtl
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >=0.16.2.2 && <0.19
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
|
@ -78,12 +66,12 @@ test-suite spec
|
|||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.ClientSpec
|
||||
, Servant.Common.BaseUrlSpec
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, aeson
|
||||
, base-compat
|
||||
, bytestring
|
||||
, containers
|
||||
, deepseq
|
||||
, hspec == 2.*
|
||||
, http-api-data
|
||||
|
|
@ -96,6 +84,7 @@ test-suite spec
|
|||
, QuickCheck >= 2.7
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-client-core
|
||||
, servant-server == 0.11.*
|
||||
, text
|
||||
, transformers
|
||||
|
|
|
|||
|
|
@ -1,510 +1,13 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
-- | This module provides 'client' which can automatically generate
|
||||
-- querying functions for each endpoint just from the type representing your
|
||||
-- API.
|
||||
module Servant.Client
|
||||
( AuthClientData
|
||||
, AuthenticateReq(..)
|
||||
, client
|
||||
, HasClient(..)
|
||||
( client
|
||||
, ClientM
|
||||
, runClientM
|
||||
, ClientEnv (ClientEnv)
|
||||
, mkAuthenticateReq
|
||||
, ServantError(..)
|
||||
, EmptyClient(..)
|
||||
, module Servant.Common.BaseUrl
|
||||
, ClientEnv(..)
|
||||
, module Servant.Client.Core.Reexport
|
||||
) where
|
||||
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Text (unpack)
|
||||
import GHC.TypeLits
|
||||
import Network.HTTP.Client (Response)
|
||||
import Network.HTTP.Media
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Servant.API
|
||||
import Servant.Client.Experimental.Auth
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.BasicAuth
|
||||
import Servant.Common.Req
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
-- | 'client' allows you to produce operations to query an API from a client.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
client :: HasClient api => Proxy api -> Client api
|
||||
client p = clientWithRoute p defReq
|
||||
|
||||
-- | This class lets us define how each API combinator
|
||||
-- influences the creation of an HTTP request. It's mostly
|
||||
-- an internal class, you can just use 'client'.
|
||||
class HasClient api where
|
||||
type Client api :: *
|
||||
clientWithRoute :: Proxy api -> Req -> Client api
|
||||
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
-- one function for querying @a@ and another one for querying @b@,
|
||||
-- stitching them together with ':<|>', which really is just like a pair.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
|
||||
type Client (a :<|> b) = Client a :<|> Client b
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy a) req :<|>
|
||||
clientWithRoute (Proxy :: Proxy b) req
|
||||
|
||||
-- | Singleton type representing a client for an empty API.
|
||||
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
|
||||
|
||||
-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
|
||||
--
|
||||
-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "nothing" :> EmptyAPI
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > (getAllBooks :<|> EmptyClient) = client myApi
|
||||
instance HasClient EmptyAPI where
|
||||
type Client EmptyAPI = EmptyClient
|
||||
clientWithRoute Proxy _ = EmptyClient
|
||||
|
||||
-- | If you use a 'Capture' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Capture'.
|
||||
-- That function will take care of inserting a textual representation
|
||||
-- of this value at the right place in the request path.
|
||||
--
|
||||
-- You can control how values for this type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: Text -> ClientM Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (Capture capture a :> api) where
|
||||
|
||||
type Client (Capture capture a :> api) =
|
||||
a -> Client api
|
||||
|
||||
clientWithRoute Proxy req val =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = unpack (toUrlPiece val)
|
||||
|
||||
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take an
|
||||
-- additional argument of a list of the type specified by your
|
||||
-- 'CaptureAll'. That function will take care of inserting a textual
|
||||
-- representation of this value at the right place in the request
|
||||
-- path.
|
||||
--
|
||||
-- You can control how these values are turned into text by specifying
|
||||
-- a 'ToHttpApiData' instance of your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
|
||||
-- >
|
||||
-- > myApi :: Proxy
|
||||
-- > myApi = Proxy
|
||||
--
|
||||
-- > getSourceFile :: [Text] -> ClientM SourceFile
|
||||
-- > getSourceFile = client myApi
|
||||
-- > -- then you can use "getSourceFile" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
|
||||
=> HasClient (CaptureAll capture a :> sublayout) where
|
||||
|
||||
type Client (CaptureAll capture a :> sublayout) =
|
||||
[a] -> Client sublayout
|
||||
|
||||
clientWithRoute Proxy req vals =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
(foldl' (flip appendToPath) req ps)
|
||||
|
||||
where ps = map (unpack . toUrlPiece) vals
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
-- Note [Non-Empty Content Types]
|
||||
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
) => HasClient (Verb method status cts' a) where
|
||||
type Client (Verb method status cts' a) = ClientM a
|
||||
clientWithRoute Proxy req = do
|
||||
snd <$> performRequestCT (Proxy :: Proxy ct) method req
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
|
||||
type Client (Verb method status cts NoContent)
|
||||
= ClientM NoContent
|
||||
clientWithRoute Proxy req = do
|
||||
performRequestNoBody method req >> return NoContent
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
instance OVERLAPPING_
|
||||
-- Note [Non-Empty Content Types]
|
||||
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
) => HasClient (Verb method status cts' (Headers ls a)) where
|
||||
type Client (Verb method status cts' (Headers ls a))
|
||||
= ClientM (Headers ls a)
|
||||
clientWithRoute Proxy req = do
|
||||
let method = reflectMethod (Proxy :: Proxy method)
|
||||
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
|
||||
return $ Headers { getResponse = resp
|
||||
, getHeadersHList = buildHeadersTo hdrs
|
||||
}
|
||||
|
||||
instance OVERLAPPING_
|
||||
( BuildHeadersTo ls, ReflectMethod method
|
||||
) => HasClient (Verb method status cts (Headers ls NoContent)) where
|
||||
type Client (Verb method status cts (Headers ls NoContent))
|
||||
= ClientM (Headers ls NoContent)
|
||||
clientWithRoute Proxy req = do
|
||||
let method = reflectMethod (Proxy :: Proxy method)
|
||||
hdrs <- performRequestNoBody method req
|
||||
return $ Headers { getResponse = NoContent
|
||||
, getHeadersHList = buildHeadersTo hdrs
|
||||
}
|
||||
|
||||
|
||||
-- | If you use a 'Header' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Header',
|
||||
-- wrapped in Maybe.
|
||||
--
|
||||
-- That function will take care of encoding this argument as Text
|
||||
-- in the request headers.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToHttpApiData' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > newtype Referer = Referer { referrer :: Text }
|
||||
-- > deriving (Eq, Show, Generic, ToHttpApiData)
|
||||
-- >
|
||||
-- > -- GET /view-my-referer
|
||||
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > viewReferer :: Maybe Referer -> ClientM Book
|
||||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (Header sym a :> api) where
|
||||
|
||||
type Client (Header sym a :> api) =
|
||||
Maybe a -> Client api
|
||||
|
||||
clientWithRoute Proxy req mval =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(\value -> Servant.Common.Req.addHeader hname value req)
|
||||
mval
|
||||
)
|
||||
|
||||
where hname = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
|
||||
-- functions.
|
||||
instance HasClient api
|
||||
=> HasClient (HttpVersion :> api) where
|
||||
|
||||
type Client (HttpVersion :> api) =
|
||||
Client api
|
||||
|
||||
clientWithRoute Proxy =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
|
||||
-- | Ignore @'Summary'@ in client functions.
|
||||
instance HasClient api => HasClient (Summary desc :> api) where
|
||||
type Client (Summary desc :> api) = Client api
|
||||
|
||||
clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)
|
||||
|
||||
-- | Ignore @'Description'@ in client functions.
|
||||
instance HasClient api => HasClient (Description desc :> api) where
|
||||
type Client (Description desc :> api) = Client api
|
||||
|
||||
clientWithRoute _ = clientWithRoute (Proxy :: Proxy api)
|
||||
|
||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'QueryParam',
|
||||
-- enclosed in Maybe.
|
||||
--
|
||||
-- If you give Nothing, nothing will be added to the query string.
|
||||
--
|
||||
-- If you give a non-'Nothing' value, this function will take care
|
||||
-- of inserting a textual representation of this value in the query string.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (QueryParam sym a :> api) where
|
||||
|
||||
type Client (QueryParam sym a :> api) =
|
||||
Maybe a -> Client api
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy req mparam =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(maybe req
|
||||
(flip (appendToQueryString pname) req . Just)
|
||||
mparamText
|
||||
)
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
mparamText = fmap toQueryParam mparam
|
||||
|
||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument, a list of values of the type specified
|
||||
-- by your 'QueryParams'.
|
||||
--
|
||||
-- If you give an empty list, nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will take care
|
||||
-- of inserting a textual representation of your values in the query string,
|
||||
-- under the same query string parameter name.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
|
||||
=> HasClient (QueryParams sym a :> api) where
|
||||
|
||||
type Client (QueryParams sym a :> api) =
|
||||
[a] -> Client api
|
||||
|
||||
clientWithRoute Proxy req paramlist =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
|
||||
req
|
||||
paramlist'
|
||||
)
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
paramlist' = map (Just . toQueryParam) paramlist
|
||||
|
||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional 'Bool' argument.
|
||||
--
|
||||
-- If you give 'False', nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will insert a value-less query string
|
||||
-- parameter under the name associated to your 'QueryFlag'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> ClientM [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient api)
|
||||
=> HasClient (QueryFlag sym :> api) where
|
||||
|
||||
type Client (QueryFlag sym :> api) =
|
||||
Bool -> Client api
|
||||
|
||||
clientWithRoute Proxy req flag =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(if flag
|
||||
then appendToQueryString paramname Nothing req
|
||||
else req
|
||||
)
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
instance HasClient Raw where
|
||||
type Client Raw
|
||||
= H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
|
||||
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
||||
clientWithRoute Proxy req httpMethod = do
|
||||
performRequest httpMethod req
|
||||
|
||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'ReqBody'.
|
||||
-- That function will take care of encoding this argument as JSON and
|
||||
-- of using it as the request body.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > addBook :: Book -> ClientM Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient api)
|
||||
=> HasClient (ReqBody (ct ': cts) a :> api) where
|
||||
|
||||
type Client (ReqBody (ct ': cts) a :> api) =
|
||||
a -> Client api
|
||||
|
||||
clientWithRoute Proxy req body =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(let ctProxy = Proxy :: Proxy ct
|
||||
in setReqBodyLBS (mimeRender ctProxy body)
|
||||
-- We use first contentType from the Accept list
|
||||
(contentType ctProxy)
|
||||
req
|
||||
)
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where
|
||||
type Client (path :> api) = Client api
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = symbolVal (Proxy :: Proxy path)
|
||||
|
||||
instance HasClient api => HasClient (Vault :> api) where
|
||||
type Client (Vault :> api) = Client api
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient api => HasClient (RemoteHost :> api) where
|
||||
type Client (RemoteHost :> api) = Client api
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient api => HasClient (IsSecure :> api) where
|
||||
type Client (IsSecure :> api) = Client api
|
||||
|
||||
clientWithRoute Proxy req =
|
||||
clientWithRoute (Proxy :: Proxy api) req
|
||||
|
||||
instance HasClient subapi =>
|
||||
HasClient (WithNamedContext name context subapi) where
|
||||
|
||||
type Client (WithNamedContext name context subapi) = Client subapi
|
||||
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
|
||||
|
||||
instance ( HasClient api
|
||||
) => HasClient (AuthProtect tag :> api) where
|
||||
type Client (AuthProtect tag :> api)
|
||||
= AuthenticateReq (AuthProtect tag) -> Client api
|
||||
|
||||
clientWithRoute Proxy req (AuthenticateReq (val,func)) =
|
||||
clientWithRoute (Proxy :: Proxy api) (func val req)
|
||||
|
||||
-- * Basic Authentication
|
||||
|
||||
instance HasClient api => HasClient (BasicAuth realm usr :> api) where
|
||||
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
|
||||
|
||||
clientWithRoute Proxy req val =
|
||||
clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)
|
||||
|
||||
|
||||
{- Note [Non-Empty Content Types]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Rather than have
|
||||
|
||||
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
|
||||
|
||||
It may seem to make more sense to have:
|
||||
|
||||
instance (...) => ... (ct ': cts) ...
|
||||
|
||||
But this means that if another instance exists that does *not* require
|
||||
non-empty lists, but is otherwise more specific, no instance will be overall
|
||||
more specific. This in turn generally means adding yet another instance (one
|
||||
for empty and one for non-empty lists).
|
||||
-}
|
||||
import Servant.Client.Internal.HttpClient
|
||||
import Servant.Client.Core.Reexport
|
||||
|
|
|
|||
149
servant-client/src/Servant/Client/Internal/HttpClient.hs
Normal file
149
servant-client/src/Servant/Client/Internal/HttpClient.hs
Normal file
|
|
@ -0,0 +1,149 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | @http-client@-based client requests executor
|
||||
module Servant.Client.Internal.HttpClient where
|
||||
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class (MonadError (..))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Sequence (fromList)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Network.HTTP.Types (hContentType, renderQuery,
|
||||
statusCode)
|
||||
import Servant.Client.Core
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
-- | The environment in which a request is run.
|
||||
data ClientEnv
|
||||
= ClientEnv
|
||||
{ manager :: Client.Manager
|
||||
, baseUrl :: BaseUrl
|
||||
}
|
||||
|
||||
-- | Generates a set of client functions for an API.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type API = Capture "no" Int :> Get '[JSON] Int
|
||||
-- > :<|> Get '[JSON] [Bool]
|
||||
-- >
|
||||
-- > api :: Proxy API
|
||||
-- > api = Proxy
|
||||
-- >
|
||||
-- > getInt :: Int -> ClientM Int
|
||||
-- > getBools :: ClientM [Bool]
|
||||
-- > getInt :<|> getBools = client api
|
||||
client :: HasClient ClientM api => Proxy api -> Client ClientM api
|
||||
client api = api `clientIn` (Proxy :: Proxy ClientM)
|
||||
|
||||
-- | @ClientM@ is the monad in which client functions run. Contains the
|
||||
-- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment.
|
||||
newtype ClientM a = ClientM
|
||||
{ runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
|
||||
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
||||
, MonadReader ClientEnv, MonadError ServantError, MonadThrow
|
||||
, MonadCatch)
|
||||
|
||||
instance MonadBase IO ClientM where
|
||||
liftBase = ClientM . liftBase
|
||||
|
||||
instance MonadBaseControl IO ClientM where
|
||||
type StM ClientM a = Either ServantError a
|
||||
|
||||
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
|
||||
|
||||
restoreM st = ClientM (restoreM st)
|
||||
|
||||
-- | Try clients in order, last error is preserved.
|
||||
instance Alt ClientM where
|
||||
a <!> b = a `catchError` \_ -> b
|
||||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
throwServantError = throwError
|
||||
catchServantError = catchError
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
mkClient = id
|
||||
|
||||
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
|
||||
|
||||
|
||||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
m <- asks manager
|
||||
burl <- asks baseUrl
|
||||
let request = requestToClientRequest burl req
|
||||
|
||||
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
|
||||
case eResponse of
|
||||
Left err -> throwError $ err
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
status_code = statusCode status
|
||||
ourResponse = clientResponseToReponse response
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
throwError $ FailureResponse ourResponse
|
||||
return ourResponse
|
||||
|
||||
clientResponseToReponse :: Client.Response BSL.ByteString -> Response
|
||||
clientResponseToReponse r = Response
|
||||
{ responseStatusCode = Client.responseStatus r
|
||||
, responseBody = Client.responseBody r
|
||||
, responseHeaders = fromList $ Client.responseHeaders r
|
||||
, responseHttpVersion = Client.responseVersion r
|
||||
}
|
||||
|
||||
requestToClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
requestToClientRequest burl r = Client.defaultRequest
|
||||
{ Client.method = requestMethod r
|
||||
, Client.host = fromString $ baseUrlHost burl
|
||||
, Client.port = baseUrlPort burl
|
||||
, Client.path = BSL.toStrict
|
||||
$ fromString (baseUrlPath burl)
|
||||
<> toLazyByteString (requestPath r)
|
||||
, Client.queryString = renderQuery True . toList $ requestQueryString r
|
||||
, Client.requestHeaders =
|
||||
let orig = toList $ requestHeaders r
|
||||
in maybe orig (: orig) contentTypeHdr
|
||||
, Client.requestBody = body
|
||||
}
|
||||
where
|
||||
(body, contentTypeHdr) = case requestBody r of
|
||||
Nothing -> (Client.RequestBodyLBS "", Nothing)
|
||||
Just (RequestBodyLBS body', typ)
|
||||
-> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
catch (Right <$> action) $ \e ->
|
||||
pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | Basic Authentication for clients
|
||||
|
||||
module Servant.Common.BasicAuth (
|
||||
basicAuthReq
|
||||
) where
|
||||
|
||||
import Data.ByteString.Base64 (encode)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Servant.Common.Req (addHeader, Req)
|
||||
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
|
||||
|
||||
-- | Authenticate a request using Basic Authentication
|
||||
basicAuthReq :: BasicAuthData -> Req -> Req
|
||||
basicAuthReq (BasicAuthData user pass) req =
|
||||
let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
|
||||
in addHeader "Authorization" authText req
|
||||
|
|
@ -1,285 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Servant.Common.Req where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch (MonadThrow, MonadCatch)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.Semigroup ((<>))
|
||||
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
import Control.Monad.Trans.Except
|
||||
|
||||
import GHC.Generics
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.IO.Class ()
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import qualified Data.ByteString.Builder as BS
|
||||
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
|
||||
import Data.String
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Typeable
|
||||
import Network.HTTP.Media
|
||||
import Network.HTTP.Types
|
||||
import Network.HTTP.Client hiding (Proxy, path)
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
import Network.URI hiding (path)
|
||||
import Servant.API.ContentTypes
|
||||
import Servant.Common.BaseUrl
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
data ServantError
|
||||
= FailureResponse
|
||||
{ failingRequest :: UrlReq
|
||||
, responseStatus :: Status
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| DecodeFailure
|
||||
{ decodeError :: String
|
||||
, responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| UnsupportedContentType
|
||||
{ responseContentType :: MediaType
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| InvalidContentTypeHeader
|
||||
{ responseContentTypeHeader :: ByteString
|
||||
, responseBody :: ByteString
|
||||
}
|
||||
| ConnectionError
|
||||
{ connectionError :: SomeException
|
||||
}
|
||||
deriving (Show, Typeable)
|
||||
|
||||
instance Eq ServantError where
|
||||
FailureResponse _ a b c == FailureResponse _ x y z =
|
||||
(a, b, c) == (x, y, z)
|
||||
DecodeFailure a b c == DecodeFailure x y z =
|
||||
(a, b, c) == (x, y, z)
|
||||
UnsupportedContentType a b == UnsupportedContentType x y =
|
||||
(a, b) == (x, y)
|
||||
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
|
||||
(a, b) == (x, y)
|
||||
ConnectionError a == ConnectionError x =
|
||||
show a == show x
|
||||
_ == _ = False
|
||||
|
||||
instance Exception ServantError
|
||||
|
||||
data UrlReq = UrlReq BaseUrl Req
|
||||
|
||||
instance Show UrlReq where
|
||||
show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)
|
||||
where
|
||||
path = cs (BS.toLazyByteString (reqPath req))
|
||||
|
||||
data Req = Req
|
||||
{ reqPath :: BS.Builder
|
||||
, qs :: QueryText
|
||||
, reqBody :: Maybe (RequestBody, MediaType)
|
||||
, reqAccept :: [MediaType]
|
||||
, headers :: [(String, Text)]
|
||||
}
|
||||
|
||||
defReq :: Req
|
||||
defReq = Req "" [] Nothing [] []
|
||||
|
||||
appendToPath :: String -> Req -> Req
|
||||
appendToPath p req =
|
||||
req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
|
||||
|
||||
appendToQueryString :: Text -- ^ param name
|
||||
-> Maybe Text -- ^ param value
|
||||
-> Req
|
||||
-> Req
|
||||
appendToQueryString pname pvalue req =
|
||||
req { qs = qs req ++ [(pname, pvalue)]
|
||||
}
|
||||
|
||||
addHeader :: ToHttpApiData a => String -> a -> Req -> Req
|
||||
addHeader name val req = req { headers = headers req
|
||||
++ [(name, decodeUtf8 (toHeader val))]
|
||||
}
|
||||
|
||||
-- | Set body and media type of the request being constructed.
|
||||
--
|
||||
-- The body is set to the given bytestring using the 'RequestBodyLBS'
|
||||
-- constructor.
|
||||
--
|
||||
{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}
|
||||
setRQBody :: ByteString -> MediaType -> Req -> Req
|
||||
setRQBody = setReqBodyLBS
|
||||
|
||||
-- | Set body and media type of the request being constructed.
|
||||
--
|
||||
-- The body is set to the given bytestring using the 'RequestBodyLBS'
|
||||
-- constructor.
|
||||
--
|
||||
-- @since 0.9.2.0
|
||||
--
|
||||
setReqBodyLBS :: ByteString -> MediaType -> Req -> Req
|
||||
setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }
|
||||
|
||||
-- | Set body and media type of the request being constructed.
|
||||
--
|
||||
-- @since 0.9.2.0
|
||||
--
|
||||
setReqBody :: RequestBody -> MediaType -> Req -> Req
|
||||
setReqBody b t req = req { reqBody = Just (b, t) }
|
||||
|
||||
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
||||
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
|
||||
setheaders . setAccept . setrqb . setQS <$> parseRequest url
|
||||
|
||||
where url = show $ nullURI { uriScheme = case reqScheme of
|
||||
Http -> "http:"
|
||||
Https -> "https:"
|
||||
, uriAuthority = Just $
|
||||
URIAuth { uriUserInfo = ""
|
||||
, uriRegName = reqHost
|
||||
, uriPort = ":" ++ show reqPort
|
||||
}
|
||||
, uriPath = fullPath
|
||||
}
|
||||
fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
|
||||
|
||||
setrqb r = case reqBody req of
|
||||
Nothing -> r
|
||||
Just (b,t) -> r { requestBody = b
|
||||
, requestHeaders = requestHeaders r
|
||||
++ [(hContentType, cs . show $ t)] }
|
||||
setQS = setQueryString $ queryTextToQuery (qs req)
|
||||
setheaders r = r { requestHeaders = requestHeaders r
|
||||
<> fmap toProperHeader (headers req) }
|
||||
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
|
||||
<> [("Accept", renderHeader $ reqAccept req)
|
||||
| not . null . reqAccept $ req] }
|
||||
toProperHeader (name, val) =
|
||||
(fromString name, encodeUtf8 val)
|
||||
|
||||
#if !MIN_VERSION_http_client(0,4,30)
|
||||
-- 'parseRequest' is introduced in http-client-0.4.30
|
||||
-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
|
||||
--
|
||||
-- See for implementations:
|
||||
-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
|
||||
-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
|
||||
parseRequest :: MonadThrow m => String -> m Request
|
||||
parseRequest url = liftM disableStatusCheck (parseUrl url)
|
||||
where
|
||||
disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
|
||||
#endif
|
||||
|
||||
|
||||
-- * performing requests
|
||||
|
||||
displayHttpRequest :: Method -> String
|
||||
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
||||
|
||||
data ClientEnv
|
||||
= ClientEnv
|
||||
{ manager :: Manager
|
||||
, baseUrl :: BaseUrl
|
||||
}
|
||||
|
||||
|
||||
-- | @ClientM@ is the monad in which client functions run. Contains the
|
||||
-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
|
||||
|
||||
newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
|
||||
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
||||
, MonadReader ClientEnv
|
||||
, MonadError ServantError
|
||||
, MonadThrow, MonadCatch
|
||||
)
|
||||
|
||||
instance MonadBase IO ClientM where
|
||||
liftBase = ClientM . liftBase
|
||||
|
||||
instance MonadBaseControl IO ClientM where
|
||||
type StM ClientM a = Either ServantError a
|
||||
|
||||
-- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
|
||||
liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
|
||||
|
||||
-- restoreM :: StM ClientM a -> ClientM a
|
||||
restoreM st = ClientM (restoreM st)
|
||||
|
||||
-- | Try clients in order, last error is preserved.
|
||||
instance Alt ClientM where
|
||||
a <!> b = a `catchError` \_ -> b
|
||||
|
||||
runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
|
||||
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
|
||||
|
||||
|
||||
performRequest :: Method -> Req
|
||||
-> ClientM ( Int, ByteString, MediaType
|
||||
, [HTTP.Header], Response ByteString)
|
||||
performRequest reqMethod req = do
|
||||
m <- asks manager
|
||||
reqHost <- asks baseUrl
|
||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||
|
||||
let request = partialRequest { Client.method = reqMethod }
|
||||
|
||||
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
|
||||
case eResponse of
|
||||
Left err ->
|
||||
throwError . ConnectionError $ SomeException err
|
||||
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
body = Client.responseBody response
|
||||
hdrs = Client.responseHeaders response
|
||||
status_code = statusCode status
|
||||
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
||||
Nothing -> pure $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
|
||||
Just t' -> pure t'
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
throwError $ FailureResponse (UrlReq reqHost req) status ct body
|
||||
return (status_code, body, ct, hdrs, response)
|
||||
|
||||
performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
|
||||
-> ClientM ([HTTP.Header], result)
|
||||
performRequestCT ct reqMethod req = do
|
||||
let acceptCTS = contentTypes ct
|
||||
(_status, respBody, respCT, hdrs, _response) <-
|
||||
performRequest reqMethod (req { reqAccept = toList acceptCTS })
|
||||
unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
|
||||
case mimeUnrender ct respBody of
|
||||
Left err -> throwError $ DecodeFailure err respCT respBody
|
||||
Right val -> return (hdrs, val)
|
||||
|
||||
performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
|
||||
performRequestNoBody reqMethod req = do
|
||||
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
|
||||
return hdrs
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
catch (Right <$> action) $ \e ->
|
||||
pure . Left . ConnectionError $ SomeException (e :: HttpException)
|
||||
|
|
@ -24,40 +24,57 @@
|
|||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
module Servant.ClientSpec where
|
||||
module Servant.ClientSpec (spec) where
|
||||
|
||||
import Control.Arrow (left)
|
||||
import Control.Concurrent (forkIO, killThread, ThreadId)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.Error.Class (throwError )
|
||||
import Data.Aeson
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import Data.Char (chr, isPrint)
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Monoid hiding (getLast)
|
||||
import Data.Proxy
|
||||
import qualified Generics.SOP as SOP
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Network.HTTP.Media
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Socket
|
||||
import Network.Wai (Request, requestHeaders, responseLBS)
|
||||
import Network.Wai.Handler.Warp
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.HUnit
|
||||
|
||||
import Control.Arrow (left)
|
||||
import Control.Concurrent (ThreadId, forkIO,
|
||||
killThread)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
import Data.Aeson
|
||||
import Data.Char (chr, isPrint)
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Monoid hiding (getLast)
|
||||
import Data.Proxy
|
||||
import qualified Generics.SOP as SOP
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Socket
|
||||
import qualified Network.Wai as Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
import Web.FormUrlEncoded (FromForm, ToForm)
|
||||
import Web.FormUrlEncoded (FromForm, ToForm)
|
||||
|
||||
import Servant.API
|
||||
import Servant.API ((:<|>) ((:<|>)),
|
||||
(:>), AuthProtect,
|
||||
BasicAuth,
|
||||
BasicAuthData (..),
|
||||
Capture,
|
||||
CaptureAll, Delete,
|
||||
DeleteNoContent,
|
||||
EmptyAPI, addHeader,
|
||||
FormUrlEncoded,
|
||||
Get, Header,
|
||||
Headers, JSON,
|
||||
NoContent (NoContent),
|
||||
Post, Put, Raw,
|
||||
QueryFlag,
|
||||
QueryParam,
|
||||
QueryParams,
|
||||
ReqBody,
|
||||
getHeaders)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Client
|
||||
import Servant.Client.Generic
|
||||
import qualified Servant.Common.Req as SCR
|
||||
import qualified Servant.Client.Core.Internal.Request as Req
|
||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
|
||||
|
|
@ -75,17 +92,16 @@ spec = describe "Servant.Client" $ do
|
|||
|
||||
-- * test data types
|
||||
|
||||
data Person = Person {
|
||||
name :: String,
|
||||
age :: Integer
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
data Person = Person
|
||||
{ _name :: String
|
||||
, _age :: Integer
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
|
||||
instance ToForm Person where
|
||||
instance FromForm Person where
|
||||
instance ToForm Person
|
||||
instance FromForm Person
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
|
@ -116,22 +132,20 @@ type Api =
|
|||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
getGet :: SCR.ClientM Person
|
||||
getDeleteEmpty :: SCR.ClientM NoContent
|
||||
getCapture :: String -> SCR.ClientM Person
|
||||
getCaptureAll :: [String] -> SCR.ClientM [Person]
|
||||
getBody :: Person -> SCR.ClientM Person
|
||||
getQueryParam :: Maybe String -> SCR.ClientM Person
|
||||
getQueryParams :: [String] -> SCR.ClientM [Person]
|
||||
getQueryFlag :: Bool -> SCR.ClientM Bool
|
||||
getRawSuccess :: HTTP.Method
|
||||
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
|
||||
getRawFailure :: HTTP.Method
|
||||
-> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
|
||||
getGet :: ClientM Person
|
||||
getDeleteEmpty :: ClientM NoContent
|
||||
getCapture :: String -> ClientM Person
|
||||
getCaptureAll :: [String] -> ClientM [Person]
|
||||
getBody :: Person -> ClientM Person
|
||||
getQueryParam :: Maybe String -> ClientM Person
|
||||
getQueryParams :: [String] -> ClientM [Person]
|
||||
getQueryFlag :: Bool -> ClientM Bool
|
||||
getRawSuccess :: HTTP.Method -> ClientM Response
|
||||
getRawFailure :: HTTP.Method -> ClientM Response
|
||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
||||
-> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
|
||||
getDeleteContentType :: SCR.ClientM NoContent
|
||||
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
getRespHeaders :: ClientM (Headers TestHeaders Bool)
|
||||
getDeleteContentType :: ClientM NoContent
|
||||
|
||||
getGet
|
||||
:<|> getDeleteEmpty
|
||||
|
|
@ -161,8 +175,8 @@ server = serve api (
|
|||
Nothing -> throwError $ ServantErr 400 "missing parameter" "" [])
|
||||
:<|> (\ names -> return (zipWith Person names [0..]))
|
||||
:<|> return
|
||||
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
|
||||
:<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
|
||||
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
|
||||
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
|
||||
:<|> (\ a b c d -> return (a, b, c, d))
|
||||
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
|
||||
:<|> return NoContent
|
||||
|
|
@ -178,9 +192,9 @@ failApi = Proxy
|
|||
|
||||
failServer :: Application
|
||||
failServer = serve failApi (
|
||||
(Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
|
||||
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
||||
:<|> (Tagged $ \_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||
(Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "")
|
||||
:<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "")
|
||||
:<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
|
||||
)
|
||||
|
||||
-- * basic auth stuff
|
||||
|
|
@ -214,16 +228,16 @@ genAuthAPI :: Proxy GenAuthAPI
|
|||
genAuthAPI = Proxy
|
||||
|
||||
type instance AuthServerData (AuthProtect "auth-tag") = ()
|
||||
type instance AuthClientData (AuthProtect "auth-tag") = ()
|
||||
type instance Auth.AuthClientData (AuthProtect "auth-tag") = ()
|
||||
|
||||
genAuthHandler :: AuthHandler Request ()
|
||||
genAuthHandler :: AuthHandler Wai.Request ()
|
||||
genAuthHandler =
|
||||
let handler req = case lookup "AuthHeader" (requestHeaders req) of
|
||||
let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of
|
||||
Nothing -> throwError (err401 { errBody = "Missing auth header" })
|
||||
Just _ -> return ()
|
||||
in mkAuthHandler handler
|
||||
|
||||
genAuthServerContext :: Context '[ AuthHandler Request () ]
|
||||
genAuthServerContext :: Context '[ AuthHandler Wai.Request () ]
|
||||
genAuthServerContext = genAuthHandler :. EmptyContext
|
||||
|
||||
genAuthServer :: Application
|
||||
|
|
@ -236,11 +250,11 @@ type GenericClientAPI
|
|||
:<|> Capture "foo" String :> NestedAPI1
|
||||
|
||||
data GenericClient = GenericClient
|
||||
{ getSqr :: Maybe Int -> SCR.ClientM Int
|
||||
{ getSqr :: Maybe Int -> ClientM Int
|
||||
, mkNestedClient1 :: String -> NestedClient1
|
||||
} deriving Generic
|
||||
instance SOP.Generic GenericClient
|
||||
instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient
|
||||
instance (Client ClientM GenericClientAPI ~ client) => ClientLike client GenericClient
|
||||
|
||||
type NestedAPI1
|
||||
= QueryParam "int" Int :> NestedAPI2
|
||||
|
|
@ -248,21 +262,21 @@ type NestedAPI1
|
|||
|
||||
data NestedClient1 = NestedClient1
|
||||
{ mkNestedClient2 :: Maybe Int -> NestedClient2
|
||||
, idChar :: Maybe Char -> SCR.ClientM Char
|
||||
, idChar :: Maybe Char -> ClientM Char
|
||||
} deriving Generic
|
||||
instance SOP.Generic NestedClient1
|
||||
instance (Client NestedAPI1 ~ client) => ClientLike client NestedClient1
|
||||
instance (Client ClientM NestedAPI1 ~ client) => ClientLike client NestedClient1
|
||||
|
||||
type NestedAPI2
|
||||
= "sum" :> Capture "first" Int :> Capture "second" Int :> Get '[JSON] Int
|
||||
:<|> "void" :> Post '[JSON] ()
|
||||
|
||||
data NestedClient2 = NestedClient2
|
||||
{ getSum :: Int -> Int -> SCR.ClientM Int
|
||||
, doNothing :: SCR.ClientM ()
|
||||
{ getSum :: Int -> Int -> ClientM Int
|
||||
, doNothing :: ClientM ()
|
||||
} deriving Generic
|
||||
instance SOP.Generic NestedClient2
|
||||
instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2
|
||||
instance (Client ClientM NestedAPI2 ~ client) => ClientLike client NestedClient2
|
||||
|
||||
genericClientServer :: Application
|
||||
genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
|
||||
|
|
@ -276,67 +290,70 @@ genericClientServer = serve (Proxy :: Proxy GenericClientAPI) (
|
|||
nestedServer1 _str = nestedServer2 :<|> (maybe (throwError $ ServantErr 400 "missing parameter" "" []) return)
|
||||
nestedServer2 _int = (\ x y -> return (x + y)) :<|> return ()
|
||||
|
||||
{-# NOINLINE manager #-}
|
||||
manager :: C.Manager
|
||||
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||
{-# NOINLINE manager' #-}
|
||||
manager' :: C.Manager
|
||||
manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
||||
|
||||
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
|
||||
runClient x baseUrl' = runClientM x (ClientEnv manager' baseUrl')
|
||||
|
||||
sucessSpec :: Spec
|
||||
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
||||
|
||||
it "Servant.API.Get" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM getGet (ClientEnv manager baseUrl))) `shouldReturn` Right alice
|
||||
left show <$> runClient getGet baseUrl `shouldReturn` Right alice
|
||||
|
||||
describe "Servant.API.Delete" $ do
|
||||
it "allows empty content type" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM getDeleteEmpty (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
||||
left show <$> runClient getDeleteEmpty baseUrl `shouldReturn` Right NoContent
|
||||
|
||||
it "allows content type" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM getDeleteContentType (ClientEnv manager baseUrl))) `shouldReturn` Right NoContent
|
||||
left show <$> runClient getDeleteContentType baseUrl `shouldReturn` Right NoContent
|
||||
|
||||
it "Servant.API.Capture" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM (getCapture "Paula") (ClientEnv manager baseUrl))) `shouldReturn` Right (Person "Paula" 0)
|
||||
left show <$> runClient (getCapture "Paula") baseUrl `shouldReturn` Right (Person "Paula" 0)
|
||||
|
||||
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
|
||||
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
|
||||
(left show <$> (runClientM (getCaptureAll ["Paula", "Peta"]) (ClientEnv manager baseUrl))) `shouldReturn` Right expected
|
||||
left show <$> runClient (getCaptureAll ["Paula", "Peta"]) baseUrl `shouldReturn` Right expected
|
||||
|
||||
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
|
||||
let p = Person "Clara" 42
|
||||
(left show <$> runClientM (getBody p) (ClientEnv manager baseUrl)) `shouldReturn` Right p
|
||||
left show <$> runClient (getBody p) baseUrl `shouldReturn` Right p
|
||||
|
||||
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
|
||||
left show <$> runClientM (getQueryParam (Just "alice")) (ClientEnv manager baseUrl) `shouldReturn` Right alice
|
||||
Left FailureResponse{..} <- runClientM (getQueryParam (Just "bob")) (ClientEnv manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
|
||||
left show <$> runClient (getQueryParam (Just "alice")) baseUrl `shouldReturn` Right alice
|
||||
Left (FailureResponse r) <- runClient (getQueryParam (Just "bob")) baseUrl
|
||||
responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found"
|
||||
|
||||
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
|
||||
(left show <$> runClientM (getQueryParams []) (ClientEnv manager baseUrl)) `shouldReturn` Right []
|
||||
(left show <$> runClientM (getQueryParams ["alice", "bob"]) (ClientEnv manager baseUrl))
|
||||
left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right []
|
||||
left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl
|
||||
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
|
||||
|
||||
context "Servant.API.QueryParam.QueryFlag" $
|
||||
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
|
||||
(left show <$> runClientM (getQueryFlag flag) (ClientEnv manager baseUrl)) `shouldReturn` Right flag
|
||||
left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag
|
||||
|
||||
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
|
||||
res <- runClientM (getRawSuccess HTTP.methodGet) (ClientEnv manager baseUrl)
|
||||
res <- runClient (getRawSuccess HTTP.methodGet) baseUrl
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right (code, body, ct, _, response) -> do
|
||||
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
|
||||
C.responseBody response `shouldBe` body
|
||||
C.responseStatus response `shouldBe` HTTP.ok200
|
||||
Right r -> do
|
||||
responseStatusCode r `shouldBe` HTTP.status200
|
||||
responseBody r `shouldBe` "rawSuccess"
|
||||
|
||||
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
|
||||
res <- runClientM (getRawFailure HTTP.methodGet) (ClientEnv manager baseUrl)
|
||||
res <- runClient (getRawFailure HTTP.methodGet) baseUrl
|
||||
case res of
|
||||
Right _ -> assertFailure "expected Left, but got Right"
|
||||
Left e -> do
|
||||
Servant.Client.responseStatus e `shouldBe` HTTP.status400
|
||||
Servant.Client.responseBody e `shouldBe` "rawFailure"
|
||||
Left (FailureResponse r) -> do
|
||||
responseStatusCode r `shouldBe` HTTP.status400
|
||||
responseBody r `shouldBe` "rawFailure"
|
||||
Left e -> assertFailure $ "expected FailureResponse, but got " ++ show e
|
||||
|
||||
it "Returns headers appropriately" $ \(_, baseUrl) -> do
|
||||
res <- runClientM getRespHeaders (ClientEnv manager baseUrl)
|
||||
res <- runClient getRespHeaders baseUrl
|
||||
case res of
|
||||
Left e -> assertFailure $ show e
|
||||
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
|
||||
|
|
@ -345,7 +362,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
|
||||
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
||||
ioProperty $ do
|
||||
result <- left show <$> runClientM (getMultiple cap num flag body) (ClientEnv manager baseUrl)
|
||||
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
|
|
@ -357,10 +374,10 @@ wrappedApiSpec = describe "error status codes" $ do
|
|||
let test :: (WrappedApi, String) -> Spec
|
||||
test (WrappedApi api, desc) =
|
||||
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
|
||||
let getResponse :: SCR.ClientM ()
|
||||
let getResponse :: ClientM ()
|
||||
getResponse = client api
|
||||
Left FailureResponse{..} <- runClientM getResponse (ClientEnv manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 500 "error message")
|
||||
Left (FailureResponse r) <- runClient getResponse baseUrl
|
||||
responseStatusCode r `shouldBe` (HTTP.Status 500 "error message")
|
||||
in mapM_ test $
|
||||
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
|
||||
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
|
||||
|
|
@ -374,42 +391,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
|
|||
context "client returns errors appropriately" $ do
|
||||
it "reports FailureResponse" $ \(_, baseUrl) -> do
|
||||
let (_ :<|> getDeleteEmpty :<|> _) = client api
|
||||
Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)
|
||||
Left res <- runClient getDeleteEmpty baseUrl
|
||||
case res of
|
||||
FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return ()
|
||||
FailureResponse r | responseStatusCode r == HTTP.status404 -> return ()
|
||||
_ -> fail $ "expected 404 response, but got " <> show res
|
||||
|
||||
it "reports DecodeFailure" $ \(_, baseUrl) -> do
|
||||
let (_ :<|> _ :<|> getCapture :<|> _) = client api
|
||||
Left res <- runClientM (getCapture "foo") (ClientEnv manager baseUrl)
|
||||
Left res <- runClient (getCapture "foo") baseUrl
|
||||
case res of
|
||||
DecodeFailure _ ("application/json") _ -> return ()
|
||||
DecodeFailure _ _ -> return ()
|
||||
_ -> fail $ "expected DecodeFailure, but got " <> show res
|
||||
|
||||
it "reports ConnectionError" $ \_ -> do
|
||||
let (getGetWrongHost :<|> _) = client api
|
||||
Left res <- runClientM getGetWrongHost (ClientEnv manager (BaseUrl Http "127.0.0.1" 19872 ""))
|
||||
Left res <- runClient getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "")
|
||||
case res of
|
||||
ConnectionError _ -> return ()
|
||||
_ -> fail $ "expected ConnectionError, but got " <> show res
|
||||
|
||||
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
|
||||
let (getGet :<|> _ ) = client api
|
||||
Left res <- runClientM getGet (ClientEnv manager baseUrl)
|
||||
Left res <- runClient getGet baseUrl
|
||||
case res of
|
||||
UnsupportedContentType ("application/octet-stream") _ -> return ()
|
||||
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
|
||||
|
||||
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
|
||||
let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
|
||||
Left res <- runClientM (getBody alice) (ClientEnv manager baseUrl)
|
||||
Left res <- runClient (getBody alice) baseUrl
|
||||
case res of
|
||||
InvalidContentTypeHeader "fooooo" _ -> return ()
|
||||
InvalidContentTypeHeader _ -> return ()
|
||||
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
|
||||
|
||||
data WrappedApi where
|
||||
WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
|
||||
HasClient api, Client api ~ SCR.ClientM ()) =>
|
||||
HasClient ClientM api, Client ClientM api ~ ClientM ()) =>
|
||||
Proxy api -> WrappedApi
|
||||
|
||||
basicAuthSpec :: Spec
|
||||
|
|
@ -419,15 +436,15 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
|
|||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "servant" "server"
|
||||
(left show <$> runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
||||
left show <$> runClient (getBasic basicAuthData) baseUrl `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
|
||||
let getBasic = client basicAuthAPI
|
||||
let basicAuthData = BasicAuthData "not" "password"
|
||||
Left FailureResponse{..} <- runClientM (getBasic basicAuthData) (ClientEnv manager baseUrl)
|
||||
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
|
||||
Left (FailureResponse r) <- runClient (getBasic basicAuthData) baseUrl
|
||||
responseStatusCode r `shouldBe` HTTP.Status 403 "Forbidden"
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
||||
|
|
@ -435,16 +452,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
|||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
||||
(left show <$> runClientM (getProtected authRequest) (ClientEnv manager baseUrl)) `shouldReturn` Right alice
|
||||
let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "AuthHeader" ("cool" :: String) req)
|
||||
left show <$> runClient (getProtected authRequest) baseUrl `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
||||
Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl)
|
||||
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||
let authRequest = Auth.mkAuthenticatedRequest () (\_ req -> Req.addHeader "Wrong" ("header" :: String) req)
|
||||
Left (FailureResponse r) <- runClient (getProtected authRequest) baseUrl
|
||||
responseStatusCode r `shouldBe` (HTTP.Status 401 "Unauthorized")
|
||||
|
||||
genericClientSpec :: Spec
|
||||
genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do
|
||||
|
|
@ -454,13 +471,13 @@ genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWa
|
|||
NestedClient1{..} = mkNestedClient1 "example"
|
||||
NestedClient2{..} = mkNestedClient2 (Just 42)
|
||||
|
||||
it "works for top-level client function" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM (getSqr (Just 5)) (ClientEnv manager baseUrl))) `shouldReturn` Right 25
|
||||
it "works for top-level client inClientM function" $ \(_, baseUrl) -> do
|
||||
left show <$> runClient (getSqr (Just 5)) baseUrl `shouldReturn` Right 25
|
||||
|
||||
it "works for nested clients" $ \(_, baseUrl) -> do
|
||||
(left show <$> (runClientM (idChar (Just 'c')) (ClientEnv manager baseUrl))) `shouldReturn` Right 'c'
|
||||
(left show <$> (runClientM (getSum 3 4) (ClientEnv manager baseUrl))) `shouldReturn` Right 7
|
||||
(left show <$> (runClientM doNothing (ClientEnv manager baseUrl))) `shouldReturn` Right ()
|
||||
left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c'
|
||||
left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7
|
||||
left show <$> runClient doNothing baseUrl `shouldReturn` Right ()
|
||||
|
||||
-- * utils
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@ flags: {}
|
|||
packages:
|
||||
- servant/
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-server/
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@ flags: {}
|
|||
packages:
|
||||
- servant/
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-server/
|
||||
|
|
@ -19,6 +20,7 @@ extra-deps:
|
|||
- hspec-expectations-0.8.2
|
||||
- hspec-wai-0.8.0
|
||||
- http-api-data-0.3.6
|
||||
- http-client-0.4.30
|
||||
- natural-transformation-0.4
|
||||
- primitive-0.6.1.0
|
||||
- servant-js-0.9.3
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
resolver: nightly-2017-09-01
|
||||
packages:
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-server/
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@ resolver: nightly-2017-04-01
|
|||
packages:
|
||||
- servant/
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-server/
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user