Hello community, here is the log from the commit of package ghc-servant-client for openSUSE:Factory checked in at 2017-08-31 20:59:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-servant-client (Old) and /work/SRC/openSUSE:Factory/.ghc-servant-client.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-servant-client" Thu Aug 31 20:59:13 2017 rev:2 rq:513485 version:0.11 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-servant-client/ghc-servant-client.changes 2017-05-10 20:51:09.541416086 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-servant-client.new/ghc-servant-client.changes 2017-08-31 20:59:15.803812858 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:06 UTC 2017 - psimons@suse.com + +- Update to version 0.11 revision 1. + +------------------------------------------------------------------- Old: ---- servant-client-0.9.1.1.tar.gz New: ---- servant-client-0.11.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-servant-client.spec ++++++ --- /var/tmp/diff_new_pack.ZDkX7K/_old 2017-08-31 20:59:17.203616182 +0200 +++ /var/tmp/diff_new_pack.ZDkX7K/_new 2017-08-31 20:59:17.231612248 +0200 @@ -19,7 +19,7 @@ %global pkg_name servant-client %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.1.1 +Version: 0.11 Release: 0 Summary: Automatical derivation of querying functions for servant webservices License: BSD-3-Clause @@ -34,18 +34,22 @@ BuildRequires: ghc-base64-bytestring-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-exceptions-devel +BuildRequires: ghc-generics-sop-devel BuildRequires: ghc-http-api-data-devel BuildRequires: ghc-http-client-devel BuildRequires: ghc-http-client-tls-devel BuildRequires: ghc-http-media-devel BuildRequires: ghc-http-types-devel +BuildRequires: ghc-monad-control-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-network-uri-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-safe-devel +BuildRequires: ghc-semigroupoids-devel BuildRequires: ghc-servant-devel BuildRequires: ghc-string-conversions-devel BuildRequires: ghc-text-devel +BuildRequires: ghc-transformers-base-devel BuildRequires: ghc-transformers-compat-devel BuildRequires: ghc-transformers-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ servant-client-0.9.1.1.tar.gz -> servant-client-0.11.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/CHANGELOG.md new/servant-client-0.11/CHANGELOG.md --- old/servant-client-0.9.1.1/CHANGELOG.md 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-client-0.11/CHANGELOG.md 2017-05-24 09:22:37.000000000 +0200 @@ -1,3 +1,37 @@ +0.11 +---- + +### Other changes + +- Path components are escaped + ([#696](https://github.com/haskell-servant/servant/pull/696)) +- `Req` `reqPath` field changed from `String` to `BS.Builder` + ([#696](https://github.com/haskell-servant/servant/pull/696)) +- Include `Req` in failure errors + ([#740](https://github.com/haskell-servant/servant/pull/740)) + +0.10 +----- + +### Breaking changes + +There shouldn't be breaking changes. Released as a part of `servant` suite. + +### Other changes + +* Add MonadBase and MonadBaseControl instances for ClientM + ([#663](https://github.com/haskell-servant/servant/issues/663)) + +* client asks for any content-type in Accept contentTypes non-empty list + ([#615](https://github.com/haskell-servant/servant/pull/615)) + +* Add `ClientLike` class that matches client functions generated using `client` + with client data structure. + ([#640](https://github.com/haskell-servant/servant/pull/640)) + +* Allow direct use of 'RequestBody' + ([#661](https://github.com/haskell-servant/servant/pull/661)) + 0.9.1.1 ------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/servant-client.cabal new/servant-client-0.11/servant-client.cabal --- old/servant-client-0.9.1.1/servant-client.cabal 2016-10-27 13:25:27.000000000 +0200 +++ new/servant-client-0.11/servant-client.cabal 2017-05-24 09:22:37.000000000 +0200 @@ -1,5 +1,5 @@ name: servant-client -version: 0.9.1.1 +version: 0.11 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -13,7 +13,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 @@ -30,6 +30,7 @@ library exposed-modules: Servant.Client + Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth @@ -37,24 +38,31 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9.1 && < 0.10 - , aeson >= 0.7 && < 1.1 + , 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 - , http-api-data >= 0.3 && < 0.4 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 , http-media >= 0.6.2 && < 0.7 , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 - , servant == 0.9.* + , semigroupoids >= 4.3 && < 5.3 + , servant == 0.11.* , string-conversions >= 0.3 && < 0.5 , 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 @@ -73,10 +81,8 @@ , Servant.Common.BaseUrlSpec build-depends: base == 4.* - , base-compat - , transformers - , transformers-compat , aeson + , base-compat , bytestring , deepseq , hspec == 2.* @@ -85,11 +91,15 @@ , http-media , http-types , HUnit + , mtl , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.9.* + , servant , servant-client - , servant-server == 0.9.* + , servant-server == 0.11.* , text + , transformers + , transformers-compat , wai , warp + , generics-sop diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Client/Generic.hs new/servant-client-0.11/src/Servant/Client/Generic.hs --- old/servant-client-0.9.1.1/src/Servant/Client/Generic.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/servant-client-0.11/src/Servant/Client/Generic.hs 2017-05-24 09:22:37.000000000 +0200 @@ -0,0 +1,164 @@ +{-# 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 + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Client.hs new/servant-client-0.11/src/Servant/Client.hs --- old/servant-client-0.9.1.1/src/Servant/Client.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-client-0.11/src/Servant/Client.hs 2017-05-24 09:22:37.000000000 +0200 @@ -24,6 +24,7 @@ , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) + , EmptyClient(..) , module Servant.Common.BaseUrl ) where @@ -88,6 +89,23 @@ 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'. @@ -406,7 +424,8 @@ clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy api) (let ctProxy = Proxy :: Proxy ct - in setRQBody (mimeRender ctProxy body) + in setReqBodyLBS (mimeRender ctProxy body) + -- We use first contentType from the Accept list (contentType ctProxy) req ) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/src/Servant/Common/Req.hs new/servant-client-0.11/src/Servant/Common/Req.hs --- old/servant-client-0.9.1.1/src/Servant/Common/Req.hs 2016-10-27 13:25:54.000000000 +0200 +++ new/servant-client-0.11/src/Servant/Common/Req.hs 2017-05-24 09:22:37.000000000 +0200 @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.Common.Req where @@ -13,21 +15,22 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch) +import Data.Foldable (toList) +import Data.Functor.Alt (Alt (..)) +import Data.Semigroup ((<>)) -#if MIN_VERSION_mtl(2,2,0) -import Control.Monad.Except (MonadError(..)) -#else import Control.Monad.Error.Class (MonadError(..)) -#endif import Control.Monad.Trans.Except - import GHC.Generics +import Control.Monad.Base (MonadBase (..)) import Control.Monad.IO.Class () import Control.Monad.Reader -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) +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 +import Data.String.Conversions (cs) import Data.Proxy import Data.Text (Text) import Data.Text.Encoding @@ -46,7 +49,8 @@ data ServantError = FailureResponse - { responseStatus :: Status + { failingRequest :: UrlReq + , responseStatus :: Status , responseContentType :: MediaType , responseBody :: ByteString } @@ -69,7 +73,7 @@ deriving (Show, Typeable) instance Eq ServantError where - FailureResponse a b c == FailureResponse x y z = + 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) @@ -83,10 +87,17 @@ 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 :: String + { reqPath :: BS.Builder , qs :: QueryText - , reqBody :: Maybe (ByteString, MediaType) + , reqBody :: Maybe (RequestBody, MediaType) , reqAccept :: [MediaType] , headers :: [(String, Text)] } @@ -96,7 +107,7 @@ appendToPath :: String -> Req -> Req appendToPath p req = - req { reqPath = reqPath req ++ "/" ++ p } + req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p } appendToQueryString :: Text -- ^ param name -> Maybe Text -- ^ param value @@ -111,8 +122,31 @@ ++ [(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 b t req = req { reqBody = Just (b, t) } +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) = @@ -126,12 +160,13 @@ , uriRegName = reqHost , uriPort = ":" ++ show reqPort } - , uriPath = path ++ reqPath req + , uriPath = fullPath } + fullPath = path ++ cs (BS.toLazyByteString (reqPath req)) setrqb r = case reqBody req of Nothing -> r - Just (b,t) -> r { requestBody = RequestBodyLBS b + Just (b,t) -> r { requestBody = b , requestHeaders = requestHeaders r ++ [(hContentType, cs . show $ t)] } setQS = setQueryString $ queryTextToQuery (qs req) @@ -179,11 +214,27 @@ , 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 +performRequest :: Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) performRequest reqMethod req = do @@ -209,16 +260,16 @@ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse status ct body + throwError $ FailureResponse (UrlReq reqHost req) status ct body return (status_code, body, ct, hdrs, response) -performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req +performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req -> ClientM ([HTTP.Header], result) performRequestCT ct reqMethod req = do - let acceptCT = contentType ct + let acceptCTS = contentTypes ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) - unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody + 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/servant-client-0.9.1.1/test/Servant/ClientSpec.hs new/servant-client-0.11/test/Servant/ClientSpec.hs --- old/servant-client-0.9.1.1/test/Servant/ClientSpec.hs 2016-10-24 18:27:44.000000000 +0200 +++ new/servant-client-0.11/test/Servant/ClientSpec.hs 2017-05-24 09:22:37.000000000 +0200 @@ -29,13 +29,14 @@ import Control.Arrow (left) import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Exception (bracket) -import Control.Monad.Trans.Except (throwE ) +import Control.Monad.Error.Class (throwError ) import Data.Aeson import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) import Data.Foldable (forM_) import Data.Monoid hiding (getLast) import Data.Proxy +import qualified Generics.SOP as SOP import GHC.Generics (Generic) import qualified Network.HTTP.Client as C import Network.HTTP.Media @@ -55,6 +56,7 @@ import Servant.API import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client +import Servant.Client.Generic import qualified Servant.Common.Req as SCR import Servant.Server import Servant.Server.Experimental.Auth @@ -69,6 +71,7 @@ wrappedApiSpec basicAuthSpec genAuthSpec + genericClientSpec -- * test data types @@ -108,6 +111,8 @@ Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent + :<|> "empty" :> EmptyAPI + api :: Proxy Api api = Proxy @@ -119,14 +124,15 @@ getQueryParam :: Maybe String -> SCR.ClientM Person getQueryParams :: [String] -> SCR.ClientM [Person] getQueryFlag :: Bool -> SCR.ClientM Bool -getRawSuccess :: HTTP.Method +getRawSuccess :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) -getRawFailure :: HTTP.Method +getRawFailure :: HTTP.Method -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) 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 + getGet :<|> getDeleteEmpty :<|> getCapture @@ -139,7 +145,8 @@ :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders - :<|> getDeleteContentType = client api + :<|> getDeleteContentType + :<|> EmptyClient = client api server :: Application server = serve api ( @@ -150,16 +157,16 @@ :<|> return :<|> (\ name -> case name of Just "alice" -> return alice - Just n -> throwE $ ServantErr 400 (n ++ " not found") "" [] - Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) + Just n -> throwError $ ServantErr 400 (n ++ " not found") "" [] + Nothing -> throwError $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent - ) + :<|> emptyServer) type FailApi = @@ -171,9 +178,9 @@ failServer :: Application failServer = serve failApi ( - (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + (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")] "") ) -- * basic auth stuff @@ -212,7 +219,7 @@ genAuthHandler :: AuthHandler Request () genAuthHandler = let handler req = case lookup "AuthHeader" (requestHeaders req) of - Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Nothing -> throwError (err401 { errBody = "Missing auth header" }) Just _ -> return () in mkAuthHandler handler @@ -222,6 +229,53 @@ genAuthServer :: Application genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) +-- * generic client stuff + +type GenericClientAPI + = QueryParam "sqr" Int :> Get '[JSON] Int + :<|> Capture "foo" String :> NestedAPI1 + +data GenericClient = GenericClient + { getSqr :: Maybe Int -> SCR.ClientM Int + , mkNestedClient1 :: String -> NestedClient1 + } deriving Generic +instance SOP.Generic GenericClient +instance (Client GenericClientAPI ~ client) => ClientLike client GenericClient + +type NestedAPI1 + = QueryParam "int" Int :> NestedAPI2 + :<|> QueryParam "id" Char :> Get '[JSON] Char + +data NestedClient1 = NestedClient1 + { mkNestedClient2 :: Maybe Int -> NestedClient2 + , idChar :: Maybe Char -> SCR.ClientM Char + } deriving Generic +instance SOP.Generic NestedClient1 +instance (Client 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 () + } deriving Generic +instance SOP.Generic NestedClient2 +instance (Client NestedAPI2 ~ client) => ClientLike client NestedClient2 + +genericClientServer :: Application +genericClientServer = serve (Proxy :: Proxy GenericClientAPI) ( + (\ mx -> case mx of + Just x -> return (x*x) + Nothing -> throwError $ ServantErr 400 "missing parameter" "" [] + ) + :<|> nestedServer1 + ) + where + 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 @@ -298,7 +352,7 @@ wrappedApiSpec :: Spec wrappedApiSpec = describe "error status codes" $ do - let serveW api = serve api $ throwE $ ServantErr 500 "error message" "" [] + let serveW api = serve api $ throwError $ ServantErr 500 "error message" "" [] context "are correctly handled by the client" $ let test :: (WrappedApi, String) -> Spec test (WrappedApi api, desc) = @@ -322,7 +376,7 @@ let (_ :<|> getDeleteEmpty :<|> _) = client api Left res <- runClientM getDeleteEmpty (ClientEnv manager baseUrl) case res of - FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () + FailureResponse _ (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \(_, baseUrl) -> do @@ -392,6 +446,22 @@ Left FailureResponse{..} <- runClientM (getProtected authRequest) (ClientEnv manager baseUrl) responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") +genericClientSpec :: Spec +genericClientSpec = beforeAll (startWaiApp genericClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.Generic" $ do + + let GenericClient{..} = mkClient (client (Proxy :: Proxy GenericClientAPI)) + 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 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 () + -- * utils startWaiApp :: Application -> IO (ThreadId, BaseUrl) ++++++ servant-client.cabal ++++++ --- /var/tmp/diff_new_pack.ZDkX7K/_old 2017-08-31 20:59:17.775535825 +0200 +++ /var/tmp/diff_new_pack.ZDkX7K/_new 2017-08-31 20:59:17.779535264 +0200 @@ -1,5 +1,5 @@ name: servant-client -version: 0.9.1.1 +version: 0.11 x-revision: 1 synopsis: automatical derivation of querying functions for servant webservices description: @@ -14,7 +14,7 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors -category: Web +category: Servant Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 @@ -31,31 +31,39 @@ library exposed-modules: Servant.Client + Servant.Client.Generic Servant.Client.Experimental.Auth Servant.Common.BaseUrl Servant.Common.BasicAuth Servant.Common.Req build-depends: - base >= 4.7 && < 4.10 + base >= 4.7 && < 4.11 , base-compat >= 0.9.1 && < 0.10 - , aeson >= 0.7 && < 1.2 + , 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 - , http-api-data >= 0.3 && < 0.4 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 , http-client >= 0.4.18.1 && < 0.6 , http-client-tls >= 0.2.2 && < 0.4 - , http-media >= 0.6.2 && < 0.7 + , http-media >= 0.6.2 && < 0.8 , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 - , servant == 0.9.* + , semigroupoids >= 4.3 && < 5.3 + , servant == 0.11.* , string-conversions >= 0.3 && < 0.5 , 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 @@ -74,10 +82,8 @@ , Servant.Common.BaseUrlSpec build-depends: base == 4.* - , base-compat - , transformers - , transformers-compat , aeson + , base-compat , bytestring , deepseq , hspec == 2.* @@ -86,11 +92,15 @@ , http-media , http-types , HUnit + , mtl , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.9.* + , servant , servant-client - , servant-server == 0.9.* + , servant-server == 0.11.* , text + , transformers + , transformers-compat , wai , warp + , generics-sop