diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------- diff --git a/servant-client.cabal b/servant-client.cabal --- a/servant-client.cabal +++ b/servant-client.cabal @@ -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 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -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 ) diff --git a/src/Servant/Client/Generic.hs b/src/Servant/Client/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Generic.hs @@ -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 --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs --- a/src/Servant/Common/Req.hs +++ b/src/Servant/Common/Req.hs @@ -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) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -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