servant-client 0.9.1.1 → 0.10

raw patch · 6 files changed

+338/−34 lines, 6 filesdep +generics-sopdep +monad-controldep +semigroupoidsdep ~aesondep ~servantdep ~servant-servernew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: generics-sop, monad-control, semigroupoids, semigroups, transformers-base

Dependency ranges changed: aeson, servant, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• servant-client.cabal +19/−9
• src/Servant/Client.hs +2/−1
• src/Servant/Client/Generic.hs +164/−0
• src/Servant/Common/Req.hs +60/−19
• test/Servant/ClientSpec.hs +71/−5

@@ -1,3 +1,25 @@+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 ------- 

@@ -1,5 +1,5 @@ name:                servant-client-version:             0.9.1.1+version:             0.10 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.2     , attoparsec            >= 0.12     && < 0.14     , base64-bytestring     >= 1.0.0.1  && < 1.1     , bytestring            >= 0.10     && < 0.11     , exceptions            >= 0.8      && < 0.9+    , generics-sop          >= 0.1.0.0  && < 0.3     , http-api-data         >= 0.3      && < 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.2+    , servant               == 0.10.*     , 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 == 0.10.*     , servant-client-    , servant-server == 0.9.*+    , servant-server == 0.10.*     , text+    , transformers+    , transformers-compat     , wai     , warp+    , generics-sop

@@ -406,7 +406,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                     )

@@ -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+

@@ -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,21 @@ 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 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@@ -86,7 +88,7 @@ data Req = Req   { reqPath   :: String   , qs        :: QueryText-  , reqBody   :: Maybe (ByteString, MediaType)+  , reqBody   :: Maybe (RequestBody, MediaType)   , reqAccept :: [MediaType]   , headers   :: [(String, Text)]   }@@ -111,9 +113,32 @@                                       ++ [(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) =     setheaders . setAccept . setrqb . setQS <$> parseRequest url@@ -131,7 +156,7 @@          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,6 +204,22 @@                              , 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 @@ -215,10 +256,10 @@ 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)

@@ -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 @@ -150,8 +153,8 @@   :<|> 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")@@ -212,7 +215,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 +225,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 +348,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) =@@ -391,6 +441,22 @@       let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "Wrong" ("header" :: String) req)       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