servant-client 0.4.4.7 → 0.5
raw patch · 12 files changed
+612/−684 lines, 12 filesdep +base64-bytestringdep +http-api-datadep +transformers-compatdep −eitherdep ~servantdep ~servant-serversetup-changed
Dependencies added: base64-bytestring, http-api-data, transformers-compat
Dependencies removed: either
Dependency ranges changed: servant, servant-server
Files
- LICENSE +1/−1
- Setup.hs +1/−1
- include/overlapping-compat.h +8/−0
- servant-client.cabal +16/−9
- src/Servant/Client.hs +158/−367
- src/Servant/Client/Experimental/Auth.hs +36/−0
- src/Servant/Common/BaseUrl.hs +45/−23
- src/Servant/Common/BasicAuth.hs +21/−0
- src/Servant/Common/Req.hs +45/−57
- test/Servant/ClientSpec.hs +243/−195
- test/Servant/Common/BaseUrlSpec.hs +37/−24
- test/Spec.hs +1/−7
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Zalora South East Asia Pte Ltd+Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
+ include/overlapping-compat.h view
@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_ {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif
servant-client.cabal view
@@ -1,5 +1,5 @@ name: servant-client-version: 0.4.4.7+version: 0.5 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that@@ -10,11 +10,12 @@ <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG> license: BSD3 license-file: LICENSE-author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni-maintainer: alpmestan@gmail.com-copyright: 2014 Zalora South East Asia Pte Ltd+author: Servant Contributors+maintainer: haskell-servant-maintainers@googlegroups.com+copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple+extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/@@ -26,28 +27,33 @@ library exposed-modules: Servant.Client+ Servant.Client.Experimental.Auth Servant.Common.BaseUrl+ Servant.Common.BasicAuth Servant.Common.Req build-depends: base >=4.7 && <5 , aeson , attoparsec+ , base64-bytestring , bytestring- , either , exceptions+ , http-api-data >= 0.1 && < 0.3 , http-client , http-client-tls , http-media , http-types , network-uri >= 2.6 , safe- , servant == 0.4.*+ , servant == 0.5.* , string-conversions , text , transformers+ , transformers-compat hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall+ include-dirs: include test-suite spec type: exitcode-stdio-1.0@@ -61,10 +67,11 @@ , Servant.Common.BaseUrlSpec build-depends: base == 4.*+ , transformers+ , transformers-compat , aeson , bytestring , deepseq- , either , hspec == 2.* , http-client , http-media@@ -72,9 +79,9 @@ , HUnit , network >= 2.6 , QuickCheck >= 2.7- , servant == 0.4.*+ , servant == 0.5.* , servant-client- , servant-server == 0.4.*+ , servant-server == 0.5.* , text , wai , warp
src/Servant/Client.hs view
@@ -4,19 +4,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if !MIN_VERSION_base(4,8,0)-{-# LANGUAGE OverlappingInstances #-}-#endif++#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- ( client+ ( AuthClientData+ , AuthenticateReq(..)+ , client , HasClient(..)+ , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl ) where@@ -24,20 +27,21 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif-import Control.Monad-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except 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.Client (Response, Manager) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP 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@@ -45,16 +49,16 @@ -- | '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 Book -- POST /books+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getAllBooks :: EitherT String IO [Book]--- > postNewBook :: Book -> EitherT String IO Book--- > (getAllBooks :<|> postNewBook) = client myApi host+-- > getAllBooks :: ExceptT String IO [Book]+-- > postNewBook :: Book -> ExceptT String IO Book+-- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080-client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout+client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout client p baseurl = clientWithRoute p defReq baseurl -- | This class lets us define how each API combinator@@ -62,9 +66,8 @@ -- an internal class, you can just use 'client'. class HasClient layout where type Client layout :: *- clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Client layout+ clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout -{-type Client layout = Client layout-} -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@,@@ -76,15 +79,15 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getAllBooks :: EitherT String IO [Book]--- > postNewBook :: Book -> EitherT String IO Book--- > (getAllBooks :<|> postNewBook) = client myApi host+-- > getAllBooks :: ExceptT String IO [Book]+-- > postNewBook :: Book -> ExceptT String IO Book+-- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b- clientWithRoute Proxy req baseurl =- clientWithRoute (Proxy :: Proxy a) req baseurl :<|>- clientWithRoute (Proxy :: Proxy b) req baseurl+ clientWithRoute Proxy req baseurl manager =+ clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>+ clientWithRoute (Proxy :: Proxy b) req baseurl manager -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -93,7 +96,7 @@ -- 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 'ToText' instance for your type.+-- text by specifying a 'ToHttpApiData' instance for your type. -- -- Example: --@@ -102,103 +105,66 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getBook :: Text -> EitherT String IO Book--- > getBook = client myApi host+-- > getBook :: Text -> ExceptT String IO Book+-- > getBook = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBook" to query that endpoint-instance (KnownSymbol capture, ToText a, HasClient sublayout)+instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl val =+ clientWithRoute Proxy req baseurl manager val = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) baseurl+ manager - where p = unpack (toText val)+ where p = unpack (toUrlPiece val) --- | If you have a 'Delete' endpoint in your API, the client--- side querying function that is created when calling 'client'--- will just require an argument that specifies the scheme, host--- and port to send the request to.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances- (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where- type Client (Delete cts' a) = EitherT ServantError IO a- clientWithRoute Proxy req baseurl =- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl+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) = ExceptT ServantError IO a+ clientWithRoute Proxy req baseurl manager =+ snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager+ where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content--- HTTP header.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasClient (Delete cts ()) where- type Client (Delete cts ()) = EitherT ServantError IO ()- clientWithRoute Proxy req baseurl =- void $ performRequestNoBody H.methodDelete req [204] baseurl+instance OVERLAPPING_+ (ReflectMethod method) => HasClient (Verb method status cts NoContent) where+ type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent+ clientWithRoute Proxy req baseurl manager =+ performRequestNoBody method req baseurl manager >> return NoContent+ where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the--- corresponding headers.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- -- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances- ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)- ) => HasClient (Delete cts' (Headers ls a)) where- type Client (Delete cts' (Headers ls a)) = EitherT ServantError IO (Headers ls a)- clientWithRoute Proxy req baseurl = do- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl+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))+ = ExceptT ServantError IO (Headers ls a)+ clientWithRoute Proxy req baseurl manager = do+ let method = reflectMethod (Proxy :: Proxy method)+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } --- | If you have a 'Get' endpoint in your API, the client--- side querying function that is created when calling 'client'--- will just require an argument that specifies the scheme, host--- and port to send the request to.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where- type Client (Get (ct ': cts) result) = EitherT ServantError IO result- clientWithRoute Proxy req baseurl =- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl---- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content--- HTTP status.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasClient (Get (ct ': cts) ()) where- type Client (Get (ct ': cts) ()) = EitherT ServantError IO ()- clientWithRoute Proxy req baseurl =- performRequestNoBody H.methodGet req [204] baseurl---- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the--- corresponding headers.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( MimeUnrender ct a, BuildHeadersTo ls- ) => HasClient (Get (ct ': cts) (Headers ls a)) where- type Client (Get (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)- clientWithRoute Proxy req baseurl = do- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl- return $ Headers { getResponse = resp+instance OVERLAPPING_+ ( BuildHeadersTo ls, ReflectMethod method+ ) => HasClient (Verb method status cts (Headers ls NoContent)) where+ type Client (Verb method status cts (Headers ls NoContent))+ = ExceptT ServantError IO (Headers ls NoContent)+ clientWithRoute Proxy req baseurl manager = do+ let method = reflectMethod (Proxy :: Proxy method)+ hdrs <- performRequestNoBody method req baseurl manager+ 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',@@ -207,12 +173,12 @@ -- 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 'ToText' instance.+-- All you need is for your type to have a 'ToHttpApiData' instance. -- -- Example: -- -- > newtype Referer = Referer { referrer :: Text }--- > deriving (Eq, Show, Generic, FromText, ToText)+-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer@@ -220,143 +186,38 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > viewReferer :: Maybe Referer -> EitherT String IO Book+-- > viewReferer :: Maybe Referer -> ExceptT String IO Book -- > viewReferer = client myApi host -- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "viewRefer" to query that endpoint -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments-instance (KnownSymbol sym, ToText a, HasClient sublayout)+instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) => HasClient (Header sym a :> sublayout) where type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req baseurl mval =+ clientWithRoute Proxy req baseurl manager mval = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) baseurl+ manager where hname = symbolVal (Proxy :: Proxy sym) --- | If you have a 'Post' endpoint in your API, the client--- side querying function that is created when calling 'client'--- will just require an argument that specifies the scheme, host--- and port to send the request to.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where- type Client (Post (ct ': cts) a) = EitherT ServantError IO a- clientWithRoute Proxy req baseurl =- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201, 202] baseurl---- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content--- HTTP header.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasClient (Post (ct ': cts) ()) where- type Client (Post (ct ': cts) ()) = EitherT ServantError IO ()- clientWithRoute Proxy req baseurl =- void $ performRequestNoBody H.methodPost req [204] baseurl---- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the--- corresponding headers.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( MimeUnrender ct a, BuildHeadersTo ls- ) => HasClient (Post (ct ': cts) (Headers ls a)) where- type Client (Post (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)- clientWithRoute Proxy req baseurl = do- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201, 202] baseurl- return $ Headers { getResponse = resp- , getHeadersHList = buildHeadersTo hdrs- }---- | If you have a 'Put' endpoint in your API, the client--- side querying function that is created when calling 'client'--- will just require an argument that specifies the scheme, host--- and port to send the request to.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where- type Client (Put (ct ': cts) a) = EitherT ServantError IO a- clientWithRoute Proxy req baseurl =- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl---- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content--- HTTP header.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasClient (Put (ct ': cts) ()) where- type Client (Put (ct ': cts) ()) = EitherT ServantError IO ()- clientWithRoute Proxy req baseurl =- void $ performRequestNoBody H.methodPut req [204] baseurl---- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the--- corresponding headers.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( MimeUnrender ct a, BuildHeadersTo ls- ) => HasClient (Put (ct ': cts) (Headers ls a)) where- type Client (Put (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)- clientWithRoute Proxy req baseurl = do- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl- return $ Headers { getResponse = resp- , getHeadersHList = buildHeadersTo hdrs- }---- | If you have a 'Patch' endpoint in your API, the client--- side querying function that is created when calling 'client'--- will just require an argument that specifies the scheme, host--- and port to send the request to.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPABLE #-}-#endif- (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where- type Client (Patch (ct ': cts) a) = EitherT ServantError IO a- clientWithRoute Proxy req baseurl =- snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl+-- | Using a 'HttpVersion' combinator in your API doesn't affect the client+-- functions.+instance HasClient sublayout+ => HasClient (HttpVersion :> sublayout) where --- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content--- HTTP header.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- HasClient (Patch (ct ': cts) ()) where- type Client (Patch (ct ': cts) ()) = EitherT ServantError IO ()- clientWithRoute Proxy req baseurl =- void $ performRequestNoBody H.methodPatch req [204] baseurl+ type Client (HttpVersion :> sublayout) =+ Client sublayout --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the--- corresponding headers.-instance-#if MIN_VERSION_base(4,8,0)- {-# OVERLAPPING #-}-#endif- ( MimeUnrender ct a, BuildHeadersTo ls- ) => HasClient (Patch (ct ': cts) (Headers ls a)) where- type Client (Patch (ct ': cts) (Headers ls a)) = EitherT ServantError IO (Headers ls a)- clientWithRoute Proxy req baseurl = do- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl- return $ Headers { getResponse = resp- , getHeadersHList = buildHeadersTo hdrs- }+ clientWithRoute Proxy =+ clientWithRoute (Proxy :: Proxy sublayout) -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -369,7 +230,7 @@ -- 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 'ToText' instance for your type.+-- text by specifying a 'ToHttpApiData' instance for your type. -- -- Example: --@@ -378,30 +239,31 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getBooksBy :: Maybe Text -> EitherT String IO [Book]+-- > getBooksBy :: Maybe Text -> ExceptT String IO [Book] -- > getBooksBy = client myApi host -- > where host = BaseUrl Http "localhost" 8080 -- > -- 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, ToText a, HasClient sublayout)+instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) => HasClient (QueryParam sym a :> sublayout) where type Client (QueryParam sym a :> sublayout) = Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string- clientWithRoute Proxy req baseurl mparam =+ clientWithRoute Proxy req baseurl manager mparam = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) baseurl+ manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym)- mparamText = fmap toText mparam+ mparamText = fmap toQueryParam mparam -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -415,7 +277,7 @@ -- under the same query string parameter name. -- -- You can control how values for your type are turned into--- text by specifying a 'ToText' instance for your type.+-- text by specifying a 'ToHttpApiData' instance for your type. -- -- Example: --@@ -424,30 +286,30 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getBooksBy :: [Text] -> EitherT String IO [Book]+-- > getBooksBy :: [Text] -> ExceptT String IO [Book] -- > getBooksBy = client myApi host -- > where host = BaseUrl Http "localhost" 8080 -- > -- 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, ToText a, HasClient sublayout)+instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) => HasClient (QueryParams sym a :> sublayout) where type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req baseurl paramlist =+ clientWithRoute Proxy req baseurl manager paramlist = clientWithRoute (Proxy :: Proxy sublayout) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' )- baseurl+ baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym)- paramlist' = map (Just . toText) paramlist+ 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@@ -465,7 +327,7 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > getBooks :: Bool -> EitherT String IO [Book]+-- > getBooks :: Bool -> ExceptT String IO [Book] -- > getBooks = client myApi host -- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "getBooks" to query that endpoint.@@ -477,152 +339,25 @@ type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req baseurl flag =+ clientWithRoute Proxy req baseurl manager flag = clientWithRoute (Proxy :: Proxy sublayout) (if flag then appendToQueryString paramname Nothing req else req )- baseurl+ baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) --- | If you use a 'MatrixParam' in one of your endpoints in your API,--- the corresponding querying function will automatically take--- an additional argument of the type specified by your 'MatrixParam',--- 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 'ToText' instance for your type.------ Example:------ > type MyApi = "books" :> MatrixParam "author" Text :> Get '[JSON] [Book]--- >--- > myApi :: Proxy MyApi--- > myApi = Proxy--- >--- > getBooksBy :: Maybe Text -> EitherT String IO [Book]--- > getBooksBy = client myApi host--- > where host = BaseUrl Http "localhost" 8080--- > -- 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, ToText a, HasClient sublayout)- => HasClient (MatrixParam sym a :> sublayout) where - type Client (MatrixParam sym a :> sublayout) =- Maybe a -> Client sublayout-- -- if mparam = Nothing, we don't add it to the query string- clientWithRoute Proxy req baseurl mparam =- clientWithRoute (Proxy :: Proxy sublayout)- (maybe req- (flip (appendToMatrixParams pname . Just) req)- mparamText- )- baseurl-- where pname = symbolVal (Proxy :: Proxy sym)- mparamText = fmap (cs . toText) mparam---- | If you use a 'MatrixParams' 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--- 'MatrixParams'.------ 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 path segment string, under the--- same matrix string parameter name.------ You can control how values for your type are turned into text by--- specifying a 'ToText' instance for your type.------ Example:------ > type MyApi = "books" :> MatrixParams "authors" Text :> Get '[JSON] [Book]--- >--- > myApi :: Proxy MyApi--- > myApi = Proxy--- >--- > getBooksBy :: [Text] -> EitherT String IO [Book]--- > getBooksBy = client myApi host--- > where host = BaseUrl Http "localhost" 8080--- > -- 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, ToText a, HasClient sublayout)- => HasClient (MatrixParams sym a :> sublayout) where-- type Client (MatrixParams sym a :> sublayout) =- [a] -> Client sublayout-- clientWithRoute Proxy req baseurl paramlist =- clientWithRoute (Proxy :: Proxy sublayout)- (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)- req- paramlist'- )- baseurl-- where pname = cs pname'- pname' = symbolVal (Proxy :: Proxy sym)- paramlist' = map (Just . toText) paramlist---- | If you use a 'MatrixFlag' 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 path segment.------ Otherwise, this function will insert a value-less matrix parameter--- under the name associated to your 'MatrixFlag'.------ Example:------ > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book]--- >--- > myApi :: Proxy MyApi--- > myApi = Proxy--- >--- > getBooks :: Bool -> EitherT String IO [Book]--- > getBooks = client myApi host--- > where host = BaseUrl Http "localhost" 8080--- > -- 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 sublayout)- => HasClient (MatrixFlag sym :> sublayout) where-- type Client (MatrixFlag sym :> sublayout) =- Bool -> Client sublayout-- clientWithRoute Proxy req baseurl flag =- clientWithRoute (Proxy :: Proxy sublayout)- (if flag- then appendToMatrixParams paramname Nothing req- else req- )- baseurl-- 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 -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)+ type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw- clientWithRoute Proxy req baseurl httpMethod = do- performRequest httpMethod req (const True) baseurl+ clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw+ clientWithRoute Proxy req baseurl manager httpMethod = do+ performRequest httpMethod req baseurl manager -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take@@ -639,8 +374,8 @@ -- > myApi :: Proxy MyApi -- > myApi = Proxy -- >--- > addBook :: Book -> EitherT String IO Book--- > addBook = client myApi host+-- > addBook :: Book -> ExceptT String IO Book+-- > addBook = client myApi host manager -- > where host = BaseUrl Http "localhost" 8080 -- > -- then you can just use "addBook" to query that endpoint instance (MimeRender ct a, HasClient sublayout)@@ -649,23 +384,79 @@ type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl body =+ clientWithRoute Proxy req baseurl manager body = clientWithRoute (Proxy :: Proxy sublayout) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) req )- baseurl+ baseurl manager -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where type Client (path :> sublayout) = Client sublayout - clientWithRoute Proxy req baseurl =+ clientWithRoute Proxy req baseurl manager = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req)- baseurl+ baseurl manager where p = symbolVal (Proxy :: Proxy path) +instance HasClient api => HasClient (Vault :> api) where+ type Client (Vault :> api) = Client api++ clientWithRoute Proxy req baseurl manager =+ clientWithRoute (Proxy :: Proxy api) req baseurl manager++instance HasClient api => HasClient (RemoteHost :> api) where+ type Client (RemoteHost :> api) = Client api++ clientWithRoute Proxy req baseurl manager =+ clientWithRoute (Proxy :: Proxy api) req baseurl manager++instance HasClient api => HasClient (IsSecure :> api) where+ type Client (IsSecure :> api) = Client api++ clientWithRoute Proxy req baseurl manager =+ clientWithRoute (Proxy :: Proxy api) req baseurl manager++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 baseurl manager (AuthenticateReq (val,func)) =+ clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager++-- * Basic Authentication++instance HasClient api => HasClient (BasicAuth realm usr :> api) where+ type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api++ clientWithRoute Proxy req baseurl manager val =+ clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager+++{- 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).+-}
+ src/Servant/Client/Experimental/Auth.hs view
@@ -0,0 +1,36 @@+{-# 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/Common/BaseUrl.hs view
@@ -1,12 +1,23 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ViewPatterns #-}-module Servant.Common.BaseUrl where+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ViewPatterns #-}+module Servant.Common.BaseUrl (+ -- * types+ BaseUrl (..)+ , InvalidBaseUrlException+ , Scheme (..)+ -- * functions+ , parseBaseUrl+ , showBaseUrl+) where -import Data.List-import GHC.Generics-import Network.URI-import Safe-import Text.Read+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 =@@ -18,14 +29,22 @@ -- 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)- } deriving (Show, Eq, Ord, Generic)+ , 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) =- schemeString ++ "//" ++ host ++ portString+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:"@@ -34,20 +53,23 @@ (Https, 443) -> "" _ -> ":" ++ show port -parseBaseUrl :: String -> Either String BaseUrl+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)))) "" "" "") ->- Right (BaseUrl Http host port)- Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->- Right (BaseUrl Http host 80)- Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->- Right (BaseUrl Https host port)- Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->- Right (BaseUrl Https host 443)+ 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 Left ("invalid base url: " ++ s)+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of
+ src/Servant/Common/BasicAuth.hs view
@@ -0,0 +1,21 @@+{-# 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 view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -10,27 +11,26 @@ import Control.Monad import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)-import Data.IORef import Data.String import Data.String.Conversions import Data.Proxy import Data.Text (Text) import Data.Text.Encoding-import Network.HTTP.Client hiding (Proxy)-import Network.HTTP.Client.TLS+import Data.Typeable+import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Media import Network.HTTP.Types import qualified Network.HTTP.Types.Header as HTTP-import Network.URI+import Network.URI hiding (path) import Servant.API.ContentTypes import Servant.Common.BaseUrl-import Servant.Common.Text-import System.IO.Unsafe import qualified Network.HTTP.Client as Client +import Web.HttpApiData+ data ServantError = FailureResponse { responseStatus :: Status@@ -46,15 +46,17 @@ { responseContentType :: MediaType , responseBody :: ByteString }- | ConnectionError- { connectionError :: HttpException- } | InvalidContentTypeHeader { responseContentTypeHeader :: ByteString , responseBody :: ByteString }- deriving (Show)+ | ConnectionError+ { connectionError :: SomeException+ }+ deriving (Show, Typeable) +instance Exception ServantError+ data Req = Req { reqPath :: String , qs :: QueryText@@ -70,13 +72,6 @@ appendToPath p req = req { reqPath = reqPath req ++ "/" ++ p } -appendToMatrixParams :: String- -> Maybe String- -> Req- -> Req-appendToMatrixParams pname pvalue req =- req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue }- appendToQueryString :: Text -- ^ param name -> Maybe Text -- ^ param value -> Req@@ -85,17 +80,17 @@ req { qs = qs req ++ [(pname, pvalue)] } -addHeader :: ToText a => String -> a -> Req -> Req+addHeader :: ToHttpApiData a => String -> a -> Req -> Req addHeader name val req = req { headers = headers req- ++ [(name, toText val)]+ ++ [(name, decodeUtf8 (toHeader val))] } setRQBody :: ByteString -> MediaType -> Req -> Req setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request-reqToRequest req (BaseUrl reqScheme reqHost reqPort) =- fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url+reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =+ setheaders . setAccept . setrqb . setQS <$> parseUrl url where url = show $ nullURI { uriScheme = case reqScheme of Http -> "http:"@@ -105,7 +100,7 @@ , uriRegName = reqHost , uriPort = ":" ++ show reqPort }- , uriPath = reqPath req+ , uriPath = path ++ reqPath req } setrqb r = case reqBody req of@@ -125,66 +120,59 @@ -- * performing requests -{-# NOINLINE __manager #-}-__manager :: IORef Manager-__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef)--__withGlobalManager :: (Manager -> IO a) -> IO a-__withGlobalManager action = readIORef __manager >>= action-- displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl- -> EitherT ServantError IO ( Int, ByteString, MediaType+performRequest :: Method -> Req -> BaseUrl -> Manager+ -> ExceptT ServantError IO ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString)-performRequest reqMethod req isWantedStatus reqHost = do+performRequest reqMethod req reqHost manager = do partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod , checkStatus = \ _status _headers _cookies -> Nothing } - eResponse <- liftIO $ __withGlobalManager $ \ manager ->- catchHttpException $- Client.httpLbs request manager+ eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of Left err ->- left $ ConnectionError err+ throwE . ConnectionError $ SomeException err Right response -> do let status = Client.responseStatus response body = Client.responseBody response- hrds = Client.responseHeaders 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 -> left $ InvalidContentTypeHeader (cs t) body+ Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Just t' -> pure t'- unless (isWantedStatus status_code) $- left $ FailureResponse status ct body- return (status_code, body, ct, hrds, response)+ unless (status_code >= 200 && status_code < 300) $+ throwE $ FailureResponse status ct body+ return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result =>- Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ([HTTP.Header], result)-performRequestCT ct reqMethod req wantedStatus reqHost = do+ Proxy ct -> Method -> Req -> BaseUrl -> Manager+ -> ExceptT ServantError IO ([HTTP.Header], result)+performRequestCT ct reqMethod req reqHost manager = do let acceptCT = contentType ct- (_status, respBody, respCT, hrds, _response) <-- performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost- unless (matches respCT (acceptCT)) $ left $ UnsupportedContentType respCT respBody+ (_status, respBody, respCT, hdrs, _response) <-+ performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager+ unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of- Left err -> left $ DecodeFailure err respCT respBody- Right val -> return (hrds, val)+ Left err -> throwE $ DecodeFailure err respCT respBody+ Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()-performRequestNoBody reqMethod req wantedStatus reqHost = do- _ <- performRequest reqMethod req (`elem` wantedStatus) reqHost- return ()+performRequestNoBody :: Method -> Req -> BaseUrl -> Manager+ -> ExceptT ServantError IO [HTTP.Header]+performRequestNoBody reqMethod req reqHost manager = do+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager+ return hdrs -catchHttpException :: IO a -> IO (Either HttpException a)-catchHttpException action =- catch (Right <$> action) (pure . Left)+catchConnectionError :: IO a -> IO (Either ServantError a)+catchConnectionError action =+ catch (Right <$> action) $ \e ->+ pure . Left . ConnectionError $ SomeException (e :: HttpException)
test/Servant/ClientSpec.hs view
@@ -1,48 +1,74 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#include "overlapping-compat.h" module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))+import Control.Applicative ((<$>)) #endif-import qualified Control.Arrow as Arrow-import Control.Concurrent-import Control.Exception-import Control.Monad.Trans.Either+import Control.Arrow (left)+import Control.Concurrent (forkIO, killThread, ThreadId)+import Control.Exception (bracket)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Aeson-import Data.ByteString.Lazy (ByteString)-import Data.Char+import Data.Char (chr, isPrint) import Data.Foldable (forM_)-import Data.Monoid+import Data.Monoid hiding (getLast) import Data.Proxy import qualified Data.Text as T-import GHC.Generics+import GHC.Generics (Generic)+import GHC.TypeLits import qualified Network.HTTP.Client as C import Network.HTTP.Media-import Network.HTTP.Types hiding (Header)-import qualified Network.HTTP.Types as HTTP+import Network.HTTP.Types (Status (..), badRequest400,+ methodGet, ok200, status400) import Network.Socket-import Network.Wai hiding (Response)+import Network.Wai (Application, Request,+ requestHeaders, responseLBS) import Network.Wai.Handler.Warp+import System.IO.Unsafe (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck import Servant.API+import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client import Servant.Server+import Servant.Server.Experimental.Auth+import qualified Servant.Common.Req as SCR +-- This declaration simply checks that all instances are in place.+_ = client comprehensiveAPI++spec :: Spec+spec = describe "Servant.Client" $ do+ sucessSpec+ failSpec+ wrappedApiSpec+ basicAuthSpec+ genAuthSpec+ -- * test data types data Person = Person {@@ -68,11 +94,6 @@ a <- lookupEither "age" xs return $ Person (T.unpack n) (read $ T.unpack a) -deriving instance Eq ServantError--instance Eq C.HttpException where- a == b = show a == show b- alice :: Person alice = Person "Alice" 42 @@ -80,15 +101,12 @@ type Api = "get" :> Get '[JSON] Person- :<|> "deleteEmpty" :> Delete '[] ()+ :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool- :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person- :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person]- :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool :<|> "rawSuccess" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :>@@ -98,37 +116,29 @@ ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)- :<|> "deleteContentType" :> Delete '[JSON] ()+ :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent api :: Proxy Api api = Proxy server :: Application server = serve api ( return alice- :<|> return ()+ :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> return :<|> (\ name -> case name of Just "alice" -> return alice- Just name -> left $ ServantErr 400 (name ++ " not found") "" []- Nothing -> left $ ServantErr 400 "missing parameter" "" [])- :<|> (\ names -> return (zipWith Person names [0..]))- :<|> return- :<|> (\ name -> case name of- Just "alice" -> return alice- Just name -> left $ ServantErr 400 (name ++ " not found") "" []- Nothing -> left $ ServantErr 400 "missing parameter" "" [])+ Just n -> throwE $ ServantErr 400 (n ++ " not found") "" []+ Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)- :<|> return ()+ :<|> return NoContent ) -withServer :: (BaseUrl -> IO a) -> IO a-withServer action = withWaiDaemon (return server) action type FailApi = "get" :> Raw@@ -144,93 +154,101 @@ :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") ) -withFailServer :: (BaseUrl -> IO a) -> IO a-withFailServer action = withWaiDaemon (return failServer) action+-- * basic auth stuff -spec :: IO ()-spec = withServer $ \ baseUrl -> do- let getGet :: EitherT ServantError IO Person- getDeleteEmpty :: EitherT ServantError IO ()- getCapture :: String -> EitherT ServantError IO Person- getBody :: Person -> EitherT ServantError IO Person- getQueryParam :: Maybe String -> EitherT ServantError IO Person- getQueryParams :: [String] -> EitherT ServantError IO [Person]- getQueryFlag :: Bool -> EitherT ServantError IO Bool- getMatrixParam :: Maybe String -> EitherT ServantError IO Person- getMatrixParams :: [String] -> EitherT ServantError IO [Person]- getMatrixFlag :: Bool -> EitherT ServantError IO Bool- getRawSuccess :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)- getRawFailure :: Method -> EitherT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], C.Response ByteString)- getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> EitherT ServantError IO (String, Maybe Int, Bool, [(String, [Rational])])- getRespHeaders :: EitherT ServantError IO (Headers TestHeaders Bool)- getDeleteContentType :: EitherT ServantError IO ()- ( getGet- :<|> getDeleteEmpty- :<|> getCapture- :<|> getBody- :<|> getQueryParam- :<|> getQueryParams- :<|> getQueryFlag- :<|> getMatrixParam- :<|> getMatrixParams- :<|> getMatrixFlag- :<|> getRawSuccess- :<|> getRawFailure- :<|> getMultiple- :<|> getRespHeaders- :<|> getDeleteContentType)- = client api baseUrl+type BasicAuthAPI =+ BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person - hspec $ do- it "Servant.API.Get" $ do- (Arrow.left show <$> runEitherT getGet) `shouldReturn` Right alice+basicAuthAPI :: Proxy BasicAuthAPI+basicAuthAPI = Proxy - describe "Servant.API.Delete" $ do- it "allows empty content type" $ do- (Arrow.left show <$> runEitherT getDeleteEmpty) `shouldReturn` Right ()+basicAuthHandler :: BasicAuthCheck ()+basicAuthHandler =+ let check (BasicAuthData username password) =+ if username == "servant" && password == "server"+ then return (Authorized ())+ else return Unauthorized+ in BasicAuthCheck check - it "allows content type" $ do- (Arrow.left show <$> runEitherT getDeleteContentType) `shouldReturn` Right ()+basicServerContext :: Context '[ BasicAuthCheck () ]+basicServerContext = basicAuthHandler :. EmptyContext - it "Servant.API.Capture" $ do- (Arrow.left show <$> runEitherT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)+basicAuthServer :: Application+basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) - it "Servant.API.ReqBody" $ do- let p = Person "Clara" 42- (Arrow.left show <$> runEitherT (getBody p)) `shouldReturn` Right p+-- * general auth stuff - it "Servant.API.QueryParam" $ do- Arrow.left show <$> runEitherT (getQueryParam (Just "alice")) `shouldReturn` Right alice- Left FailureResponse{..} <- runEitherT (getQueryParam (Just "bob"))- responseStatus `shouldBe` Status 400 "bob not found"+type GenAuthAPI =+ AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person - it "Servant.API.QueryParam.QueryParams" $ do- (Arrow.left show <$> runEitherT (getQueryParams [])) `shouldReturn` Right []- (Arrow.left show <$> runEitherT (getQueryParams ["alice", "bob"]))- `shouldReturn` Right [Person "alice" 0, Person "bob" 1]+genAuthAPI :: Proxy GenAuthAPI+genAuthAPI = Proxy - context "Servant.API.QueryParam.QueryFlag" $- forM_ [False, True] $ \ flag ->- it (show flag) $ do- (Arrow.left show <$> runEitherT (getQueryFlag flag)) `shouldReturn` Right flag+type instance AuthServerData (AuthProtect "auth-tag") = ()+type instance AuthClientData (AuthProtect "auth-tag") = () - it "Servant.API.MatrixParam" $ do- Arrow.left show <$> runEitherT (getMatrixParam (Just "alice")) `shouldReturn` Right alice- Left FailureResponse{..} <- runEitherT (getMatrixParam (Just "bob"))+genAuthHandler :: AuthHandler Request ()+genAuthHandler =+ let handler req = case lookup "AuthHeader" (requestHeaders req) of+ Nothing -> throwE (err401 { errBody = "Missing auth header" })+ Just _ -> return ()+ in mkAuthHandler handler++genAuthServerContext :: Context '[ AuthHandler Request () ]+genAuthServerContext = genAuthHandler :. EmptyContext++genAuthServer :: Application+genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))++{-# NOINLINE manager #-}+manager :: C.Manager+manager = unsafePerformIO $ C.newManager C.defaultManagerSettings++sucessSpec :: Spec+sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do++ it "Servant.API.Get" $ \(_, baseUrl) -> do+ let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager+ (left show <$> runExceptT getGet) `shouldReturn` Right alice++ describe "Servant.API.Delete" $ do+ it "allows empty content type" $ \(_, baseUrl) -> do+ let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager+ (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent++ it "allows content type" $ \(_, baseUrl) -> do+ let getDeleteContentType = getLast $ client api baseUrl manager+ (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent++ it "Servant.API.Capture" $ \(_, baseUrl) -> do+ let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager+ (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)++ it "Servant.API.ReqBody" $ \(_, baseUrl) -> do+ let p = Person "Clara" 42+ getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager+ (left show <$> runExceptT (getBody p)) `shouldReturn` Right p++ it "Servant.API.QueryParam" $ \(_, baseUrl) -> do+ let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager+ left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice+ Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) responseStatus `shouldBe` Status 400 "bob not found" - it "Servant.API.MatrixParam.MatrixParams" $ do- Arrow.left show <$> runEitherT (getMatrixParams []) `shouldReturn` Right []- Arrow.left show <$> runEitherT (getMatrixParams ["alice", "bob"])+ it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do+ let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager+ (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []+ (left show <$> runExceptT (getQueryParams ["alice", "bob"])) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] - context "Servant.API.MatrixParam.MatrixFlag" $- forM_ [False, True] $ \ flag ->- it (show flag) $ do- Arrow.left show <$> runEitherT (getMatrixFlag flag) `shouldReturn` Right flag+ context "Servant.API.QueryParam.QueryFlag" $+ forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do+ let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager+ (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag - it "Servant.API.Raw on success" $ do- res <- runEitherT (getRawSuccess methodGet)+ it "Servant.API.Raw on success" $ \(_, baseUrl) -> do+ let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager+ res <- runExceptT (getRawSuccess methodGet) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do@@ -238,133 +256,141 @@ C.responseBody response `shouldBe` body C.responseStatus response `shouldBe` ok200 - it "Servant.API.Raw on failure" $ do- res <- runEitherT (getRawFailure methodGet)+ it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do+ let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager+ res <- runExceptT (getRawFailure methodGet) case res of- Left e -> assertFailure $ show e- Right (code, body, ct, _, response) -> do- (code, body, ct) `shouldBe` (400, "rawFailure", "application"//"octet-stream")- C.responseBody response `shouldBe` body- C.responseStatus response `shouldBe` badRequest400+ Right _ -> assertFailure "expected Left, but got Right"+ Left e -> do+ Servant.Client.responseStatus e `shouldBe` status400+ Servant.Client.responseBody e `shouldBe` "rawFailure" - it "Returns headers appropriately" $ withServer $ \ _ -> do- res <- runEitherT getRespHeaders+ it "Returns headers appropriately" $ \(_, baseUrl) -> do+ let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager+ res <- runExceptT getRespHeaders case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] modifyMaxSuccess (const 20) $ do- it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $- property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->+ it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->+ let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager+ in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do- result <- Arrow.left show <$> runEitherT (getMultiple cap num flag body)+ result <- left show <$> runExceptT (getMultiple cap num flag body) return $ result === Right (cap, num, flag, body) - context "client correctly handles error status codes" $ do- let test :: (WrappedApi, String) -> Spec- test (WrappedApi api, desc) =- it desc $- withWaiDaemon (return (serve api (left $ ServantErr 500 "error message" "" []))) $- \ host -> do- let getResponse :: EitherT ServantError IO ()- getResponse = client api host- Left FailureResponse{..} <- runEitherT getResponse- responseStatus `shouldBe` (Status 500 "error message")- mapM_ test $+wrappedApiSpec :: Spec+wrappedApiSpec = describe "error status codes" $ do+ let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" []+ context "are correctly handled by the client" $+ let test :: (WrappedApi, String) -> Spec+ test (WrappedApi api, desc) =+ it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do+ let getResponse :: ExceptT ServantError IO ()+ getResponse = client api baseUrl manager+ Left FailureResponse{..} <- runExceptT getResponse+ responseStatus `shouldBe` (Status 500 "error message")+ in mapM_ test $ (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Post '[JSON] ())), "Post") : (WrappedApi (Proxy :: Proxy (Put '[JSON] ())), "Put") : [] -failSpec :: IO ()-failSpec = withFailServer $ \ baseUrl -> do- let getGet :: EitherT ServantError IO Person- getDeleteEmpty :: EitherT ServantError IO ()- getCapture :: String -> EitherT ServantError IO Person- getBody :: Person -> EitherT ServantError IO Person- ( getGet- :<|> getDeleteEmpty- :<|> getCapture- :<|> getBody- :<|> _ )- = client api baseUrl- getGetWrongHost :: EitherT ServantError IO Person- (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872)+failSpec :: Spec+failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do - hspec $ do context "client returns errors appropriately" $ do- it "reports FailureResponse" $ do- Left res <- runEitherT getDeleteEmpty+ it "reports FailureResponse" $ \(_, baseUrl) -> do+ let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager+ Left res <- runExceptT getDeleteEmpty case res of FailureResponse (Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res - it "reports DecodeFailure" $ do- Left res <- runEitherT (getCapture "foo")+ it "reports DecodeFailure" $ \(_, baseUrl) -> do+ let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager+ Left res <- runExceptT (getCapture "foo") case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res - it "reports ConnectionError" $ do- Left res <- runEitherT getGetWrongHost+ it "reports ConnectionError" $ \_ -> do+ let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager+ Left res <- runExceptT getGetWrongHost case res of- ConnectionError (C.FailedConnectionException2 "127.0.0.1" 19872 False _) -> return ()+ ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res - it "reports UnsupportedContentType" $ do- Left res <- runEitherT getGet+ it "reports UnsupportedContentType" $ \(_, baseUrl) -> do+ let (getGet :<|> _ ) = client api baseUrl manager+ Left res <- runExceptT getGet case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res - it "reports InvalidContentTypeHeader" $ do- Left res <- runEitherT (getBody alice)+ it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do+ let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager+ Left res <- runExceptT (getBody alice) case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res data WrappedApi where- WrappedApi :: (HasServer api, Server api ~ EitherT ServantErr IO a,- HasClient api, Client api ~ EitherT ServantError IO ()) =>+ WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,+ HasClient api, Client api ~ ExceptT ServantError IO ()) => Proxy api -> WrappedApi +basicAuthSpec :: Spec+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do+ context "Authentication works when requests are properly authenticated" $ do + it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do+ let getBasic = client basicAuthAPI baseUrl manager+ let basicAuthData = BasicAuthData "servant" "server"+ (left show <$> runExceptT (getBasic basicAuthData)) `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 baseUrl manager+ let basicAuthData = BasicAuthData "not" "password"+ Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)+ responseStatus `shouldBe` Status 403 "Forbidden"++genAuthSpec :: Spec+genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do+ context "Authentication works when requests are properly authenticated" $ do++ it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do+ let getProtected = client genAuthAPI baseUrl manager+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)+ (left show <$> runExceptT (getProtected authRequest)) `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 baseUrl manager+ let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)+ Left FailureResponse{..} <- runExceptT (getProtected authRequest)+ responseStatus `shouldBe` (Status 401 "Unauthorized")+ -- * utils -withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a-withWaiDaemon mkApplication action = do- application <- mkApplication- bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl)- where- acquire application = do- (notifyStart, waitForStart) <- lvar- (notifyKilled, waitForKilled) <- lvar- thread <- forkIO $ (do- (krakenPort, socket) <- openTestSocket- let settings =- setPort krakenPort $ -- set here just for consistency, shouldn't be- -- used (it's set in the socket)- setBeforeMainLoop (notifyStart krakenPort)- defaultSettings- runSettingsSocket settings socket application)- `finally` notifyKilled ()- krakenPort <- waitForStart- let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}- return (thread, waitForKilled, baseUrl)- free (thread, waitForKilled, _) = do- killThread thread- waitForKilled+startWaiApp :: Application -> IO (ThreadId, BaseUrl)+startWaiApp app = do+ (port, socket) <- openTestSocket+ let settings = setPort port $ defaultSettings+ thread <- forkIO $ runSettingsSocket settings socket app+ return (thread, BaseUrl Http "localhost" port "") - lvar :: IO (a -> IO (), IO a)- lvar = do- mvar <- newEmptyMVar- let put = putMVar mvar- wait = readMVar mvar- return (put, wait) +endWaiApp :: (ThreadId, BaseUrl) -> IO ()+endWaiApp (thread, _) = killThread thread+ openTestSocket :: IO (Port, Socket) openTestSocket = do s <- socket AF_INET Stream defaultProtocol@@ -381,3 +407,25 @@ filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127]++class GetNth (n :: Nat) a b | n a -> b where+ getNth :: Proxy n -> a -> b++instance OVERLAPPING_+ GetNth 0 (x :<|> y) x where+ getNth _ (x :<|> _) = x++instance OVERLAPPING_+ (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where+ getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x++class GetLast a b | a -> b where+ getLast :: a -> b++instance OVERLAPPING_+ (GetLast b c) => GetLast (a :<|> b) c where+ getLast (_ :<|> b) = getLast b++instance OVERLAPPING_+ GetLast a a where+ getLast a = a
test/Servant/Common/BaseUrlSpec.hs view
@@ -1,72 +1,85 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Common.BaseUrlSpec where #if !MIN_VERSION_base(4,8,0)-import Control.Applicative+import Control.Applicative #endif-import Control.DeepSeq-import Test.Hspec-import Test.QuickCheck+import Control.DeepSeq+import Test.Hspec+import Test.QuickCheck -import Servant.Common.BaseUrl+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"-+ 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"+ 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+ BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 "" describe "parseBaseUrl" $ do it "is total" $ do property $ \ string ->- deepseq (fmap show (parseBaseUrl string)) True+ deepseq (fmap show (parse string )) True it "is the inverse of showBaseUrl" $ do- property $ \ baseUrl ->- counterexample (showBaseUrl baseUrl) $- parseBaseUrl (showBaseUrl baseUrl) ===- Right baseUrl+ property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $+ parse (showBaseUrl baseUrl) === Just baseUrl - it "allows trailing slashes" $ do- parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)+ 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- parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)+ parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") it "allows port numbers" $ do- parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)+ 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- parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft+ parse "ftp://foo.com" `shouldBe` Nothing instance Arbitrary BaseUrl where arbitrary = BaseUrl <$> elements [Http, Https] <*> hostNameGen <*>- portGen+ 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- let letters = ['a' .. 'z'] ++ ['A' .. 'Z'] first <- elements letters middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])- last <- elements letters- return (first : middle ++ [last])+ 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)
test/Spec.hs view
@@ -1,7 +1,1 @@-import Servant.ClientSpec (spec, failSpec)--main :: IO ()-main = do- spec- failSpec-+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}