servant-client 0.11 → 0.12
raw patch · 11 files changed
+335/−1303 lines, 11 filesdep +containersdep +servant-client-coredep −base64-bytestringdep −network-uridep −safedep ~generics-sopdep ~http-api-datadep ~http-client
Dependencies added: containers, servant-client-core
Dependencies removed: base64-bytestring, network-uri, safe, semigroups, string-conversions
Dependency ranges changed: generics-sop, http-api-data, http-client, mtl, servant, servant-server
Files
- CHANGELOG.md +9/−0
- servant-client.cabal +23/−28
- src/Servant/Client.hs +5/−490
- src/Servant/Client/Experimental/Auth.hs +0/−36
- src/Servant/Client/Generic.hs +0/−164
- src/Servant/Client/Internal/HttpClient.hs +153/−0
- src/Servant/Common/BaseUrl.hs +0/−77
- src/Servant/Common/BasicAuth.hs +0/−21
- src/Servant/Common/Req.hs +0/−285
- test/Servant/ClientSpec.hs +145/−119
- test/Servant/Common/BaseUrlSpec.hs +0/−83
CHANGELOG.md view
@@ -1,3 +1,12 @@+[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md)+[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)++0.12+----++- Factored out into `servant-client-core` all the functionality that was+ independent of the `http-client` backend.+ 0.11 ----
servant-client.cabal view
@@ -1,5 +1,5 @@ name: servant-client-version: 0.11+version: 0.12 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that@@ -12,11 +12,15 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com-copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors-category: Servant Web+copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors+category: Servant, Web build-type: Simple cabal-version: >=1.10-tested-with: GHC >= 7.8+tested-with:+ GHC==7.8.4+ GHC==7.10.3+ GHC==8.0.2+ GHC==8.2.1 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files:@@ -30,39 +34,27 @@ 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.10+ 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.7- , http-types >= 0.8.6 && < 0.10+ , http-media >= 0.6.2 && < 0.8+ , http-types >= 0.8.6 && < 0.11+ , 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.12.* , 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@@ -76,14 +68,16 @@ default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs+ build-tool-depends:+ hspec-discover:hspec-discover other-modules: Servant.ClientSpec- , Servant.Common.BaseUrlSpec build-depends: base == 4.* , aeson , base-compat , bytestring+ , containers , deepseq , hspec == 2.* , http-api-data@@ -96,7 +90,8 @@ , QuickCheck >= 2.7 , servant , servant-client- , servant-server == 0.11.*+ , servant-client-core+ , servant-server == 0.12.* , text , transformers , transformers-compat
src/Servant/Client.hs view
@@ -1,498 +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)---- | 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
− src/Servant/Client/Experimental/Auth.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE TypeFamilies #-}---- | Authentication for clients--module Servant.Client.Experimental.Auth (- AuthenticateReq(AuthenticateReq, unAuthReq)- , AuthClientData- , mkAuthenticateReq- ) where--import Servant.Common.Req (Req)---- | For a resource protected by authentication (e.g. AuthProtect), we need--- to provide the client with some data used to add authentication data--- to a request------ NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-type family AuthClientData a :: *---- | For better type inference and to avoid usage of a data family, we newtype--- wrap the combination of some 'AuthClientData' and a function to add authentication--- data to a request------ NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE-newtype AuthenticateReq a =- AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }---- | 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)
− src/Servant/Client/Generic.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#include "overlapping-compat.h"--module Servant.Client.Generic- ( ClientLike(..)- , genericMkClientL- , genericMkClientP- ) 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.------ The client structure needs a 'Generics.SOP.Generic' instance.------ Example:------ > type API--- > = "foo" :> Capture "x" Int :> Get '[JSON] Int--- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int]--- > :<|> Capture "nested" Int :> NestedAPI--- >--- > type NestedAPI--- > = Get '[JSON] String--- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] ()--- >--- > data APIClient = APIClient--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int]--- > , mkNestedClient :: Int -> NestedClient--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient--- >--- > data NestedClient = NestedClient--- > { getString :: ClientM String--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic NestedClient--- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))------ By default, left-nested alternatives are expanded:------ > type API1--- > = "foo" :> Capture "x" Int :> Get '[JSON] Int--- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String--- >--- > type API2--- > = "baz" :> QueryParam "c" Char :> Post '[JSON] ()--- >--- > type API = API1 :<|> API2--- >--- > data APIClient = APIClient--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> ClientM String--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))------ If you want to define client for @API1@ as a separate data structure,--- you can use 'genericMkClientP':------ > data APIClient1 = APIClient1--- > { getFoo :: Int -> ClientM Int--- > , postBar :: Maybe Char -> ClientM String--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient1--- > instance (Client API1 ~ client) => ClientLike client APIClient1--- >--- > data APIClient = APIClient--- > { mkAPIClient1 :: APIClient1--- > , postBaz :: Maybe Char -> ClientM ()--- > } deriving GHC.Generic--- >--- > instance Generics.SOP.Generic APIClient--- > instance (Client API ~ client) => ClientLike client APIClient where--- > mkClient = genericMkClientP--- >--- > mkAPIClient :: APIClient--- > mkAPIClient = mkClient (client (Proxy :: Proxy API))-class ClientLike client custom where- mkClient :: client -> custom- default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)- => client -> custom- mkClient = genericMkClientL--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- gMkClientP :: client -> NP I xs--instance (GClientLikeP b (y ': xs), ClientLike a x)- => GClientLikeP (a :<|> b) (x ': y ': xs) where- gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b--instance ClientLike a x => GClientLikeP a '[x] where- gMkClientP a = I (mkClient a) :* Nil---- | Match client structure with client functions, expanding left-nested API clients--- in the same structure.-class GClientLikeL (xs :: [*]) (ys :: [*]) where- gMkClientL :: NP I xs -> NP I ys--instance GClientLikeL '[] '[] where- gMkClientL Nil = Nil--instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where- gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs--type family ClientList (client :: *) (acc :: [*]) :: [*] where- ClientList (a :<|> b) acc = ClientList a (ClientList b acc)- ClientList a acc = a ': acc--class GClientList client (acc :: [*]) where- gClientList :: client -> NP I acc -> NP I (ClientList client acc)--instance (GClientList b acc, GClientList a (ClientList b acc))- => GClientList (a :<|> b) acc where- gClientList (a :<|> b) acc = gClientList a (gClientList b acc)--instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc))- => GClientList client acc where- gClientList c acc = I c :* acc---- | Generate client structure from client type, expanding left-nested API (done by default).-genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs)- => client -> custom-genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil---- | Generate client structure from client type, regarding left-nested API clients as separate data structures.-genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs)- => client -> custom-genericMkClientP = to . SOP . Z . gMkClientP-
+ src/Servant/Client/Internal/HttpClient.hs view
@@ -0,0 +1,153 @@+{-# 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+ , Client.secure = isSecure+ }+ where+ (body, contentTypeHdr) = case requestBody r of+ Nothing -> (Client.RequestBodyLBS "", Nothing)+ Just (RequestBodyLBS body', typ)+ -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))+ isSecure = case baseUrlScheme burl of+ Http -> False+ Https -> True++catchConnectionError :: IO a -> IO (Either ServantError a)+catchConnectionError action =+ catch (Right <$> action) $ \e ->+ pure . Left . ConnectionError . T.pack $ show (e :: Client.HttpException)
− src/Servant/Common/BaseUrl.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ViewPatterns #-}-module Servant.Common.BaseUrl (- -- * types- BaseUrl (..)- , InvalidBaseUrlException- , Scheme (..)- -- * functions- , parseBaseUrl- , showBaseUrl-) where--import Control.Monad.Catch (Exception, MonadThrow, throwM)-import Data.List-import Data.Typeable-import GHC.Generics-import Network.URI hiding (path)-import Safe-import Text.Read---- | URI scheme to use-data Scheme =- Http -- ^ http://- | Https -- ^ https://- deriving (Show, Eq, Ord, Generic)---- | Simple data type to represent the target of HTTP requests--- for servant's automatically-generated clients.-data BaseUrl = BaseUrl- { baseUrlScheme :: Scheme -- ^ URI scheme to use- , baseUrlHost :: String -- ^ host (eg "haskell.org")- , baseUrlPort :: Int -- ^ port (eg 80)- , baseUrlPath :: String -- ^ path (eg "/a/b/c")- } deriving (Show, Ord, Generic)--instance Eq BaseUrl where- BaseUrl a b c path == BaseUrl a' b' c' path'- = a == a' && b == b' && c == c' && s path == s path'- where s ('/':x) = x- s x = x--showBaseUrl :: BaseUrl -> String-showBaseUrl (BaseUrl urlscheme host port path) =- schemeString ++ "//" ++ host ++ (portString </> path)- where- a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b- schemeString = case urlscheme of- Http -> "http:"- Https -> "https:"- portString = case (urlscheme, port) of- (Http, 80) -> ""- (Https, 443) -> ""- _ -> ":" ++ show port--data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)-instance Exception InvalidBaseUrlException--parseBaseUrl :: MonadThrow m => String -> m BaseUrl-parseBaseUrl s = case parseURI (removeTrailingSlash s) of- -- This is a rather hacky implementation and should be replaced with something- -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).- Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->- return (BaseUrl Http host port path)- Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->- return (BaseUrl Http host 80 path)- Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->- return (BaseUrl Https host port path)- Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->- return (BaseUrl Https host 443 path)- _ -> if "://" `isInfixOf` s- then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)- else parseBaseUrl ("http://" ++ s)- where- removeTrailingSlash str = case lastMay str of- Just '/' -> init str- _ -> str
− src/Servant/Common/BasicAuth.hs
@@ -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
− src/Servant/Common/Req.hs
@@ -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)
test/Servant/ClientSpec.hs view
@@ -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 Prelude ()+import Prelude.Compat++import Control.Arrow (left)+import Control.Concurrent (ThreadId, forkIO,+ killThread)+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.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 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 Network.Wai (Request, requestHeaders, responseLBS)+import qualified Network.Wai as Wai import Network.Wai.Handler.Warp-import Prelude ()-import Prelude.Compat-import System.IO.Unsafe (unsafePerformIO)-import Test.HUnit+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,25 +92,28 @@ -- * 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 +carol :: Person+carol = Person "Carol" 17+ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api =- "get" :> Get '[JSON] Person+ Get '[JSON] Person+ :<|> "get" :> Get '[JSON] Person :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]@@ -116,24 +136,24 @@ 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)+getRoot :: ClientM Person+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+getRoot+ :<|> getGet :<|> getDeleteEmpty :<|> getCapture :<|> getCaptureAll@@ -150,7 +170,8 @@ server :: Application server = serve api (- return alice+ return carol+ :<|> return alice :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> (\ names -> return (zipWith Person names [0..]))@@ -161,8 +182,8 @@ 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 +199,9 @@ 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 +235,16 @@ 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 +257,11 @@ :<|> 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 +269,21 @@ 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 +297,72 @@ 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 root" $ \(_, baseUrl) -> do+ left show <$> runClient getRoot baseUrl `shouldReturn` Right carol 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 +371,7 @@ 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 +383,10 @@ 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") :@@ -373,43 +399,43 @@ context "client returns errors appropriately" $ do it "reports FailureResponse" $ \(_, baseUrl) -> do- let (_ :<|> getDeleteEmpty :<|> _) = client api- Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl)+ let (_ :<|> _ :<|> getDeleteEmpty :<|> _) = client api+ 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)+ let (_ :<|> _ :<|> _ :<|> getCapture :<|> _) = client api+ 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)+ let (_ :<|> getGet :<|> _ ) = client api+ 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)+ let (_ :<|> _ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api+ 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 +445,15 @@ 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 +461,16 @@ 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 +480,13 @@ 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
− test/Servant/Common/BaseUrlSpec.hs
@@ -1,83 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Servant.Common.BaseUrlSpec where--import Control.DeepSeq-import Prelude ()-import Prelude.Compat-import Test.Hspec-import Test.QuickCheck--import Servant.Common.BaseUrl--spec :: Spec-spec = do- let parse = parseBaseUrl :: String -> Maybe BaseUrl- describe "showBaseUrl" $ do- it "shows a BaseUrl" $ do- showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com"- it "shows a https BaseUrl" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com"- it "shows the path of a BaseUrl" $ do- showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api"- it "shows the path of an https BaseUrl" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api"- it "handles leading slashes in path" $ do- showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api"-- describe "httpBaseUrl" $ do- it "allows to construct default http BaseUrls" $ do- BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 ""-- describe "parseBaseUrl" $ do- it "is total" $ do- property $ \ string ->- deepseq (fmap show (parse string )) True-- it "is the inverse of showBaseUrl" $ do- property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $- parse (showBaseUrl baseUrl) === Just baseUrl-- context "trailing slashes" $ do- it "allows trailing slashes" $ do- parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")-- it "allows trailing slashes in paths" $ do- parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")-- context "urls without scheme" $ do- it "assumes http" $ do- parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "")-- it "allows port numbers" $ do- parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "")-- it "can parse paths" $ do- parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api")-- it "rejects ftp urls" $ do- parse "ftp://foo.com" `shouldBe` Nothing--instance Arbitrary BaseUrl where- arbitrary = BaseUrl <$>- elements [Http, Https] <*>- hostNameGen <*>- portGen <*>- pathGen- where- letters = ['a' .. 'z'] ++ ['A' .. 'Z']- -- this does not perfectly mirror the url standard, but I hope it's good- -- enough.- hostNameGen = do- first <- elements letters- middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])- last' <- elements letters- return (first : middle ++ [last'])- portGen = frequency $- (1, return 80) :- (1, return 443) :- (1, choose (1, 20000)) :- []- pathGen = listOf1 . elements $ letters--isLeft :: Either a b -> Bool-isLeft = either (const True) (const False)