diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,48 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.14 +---- + +- `Stream` takes a status code argument + + ```diff + -Stream method framing ctype a + +Stream method status framing ctype a + ``` + + ([#966](https://github.com/haskell-servant/servant/pull/966) + [#972](https://github.com/haskell-servant/servant/pull/972)) + +- `ToStreamGenerator` definition changed, so it's possible to write an instance + for conduits. + + ```diff + -class ToStreamGenerator f a where + - toStreamGenerator :: f a -> StreamGenerator a + +class ToStreamGenerator a b | a -> b where + + toStreamGenerator :: a -> StreamGenerator b + ``` + + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- Added `NoFraming` streaming strategy + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- *servant-client-core* Add `hoistClient` to `HasClient`. + Just like `hoistServer` allows us to change the monad in which request handlers + of a web application live in, we also have `hoistClient` for changing the monad + in which *client functions* live. + Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). + ([#936](https://github.com/haskell-servant/servant/pull/936)) + +- *servant-client* Add more constructors to `RequestBody`, including + `RequestBodyStream`. + *Note:* we are looking for http-library agnostic API, + so the might change again soon. + Tell us which constructors are useful for you! + ([#913](https://github.com/haskell-servant/servant/pull/913)) + 0.13.0.1 -------- diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,41 @@ +# servant-client + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +This library lets you automatically derive Haskell functions that let you query each endpoint of a *servant* webservice. + +## Example + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Proxy +import Data.Text +import Network.HTTP.Client (newManager, defaultManagerSettings) +import Servant.API +import Servant.Client + + +type Book = Text + +type MyApi = "books" :> Get '[JSON] [Book] -- GET /books + :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books + +myApi :: Proxy MyApi +myApi = Proxy + +-- 'client' allows you to produce operations to query an API from a client. +postNewBook :: Book -> ClientM Book +getAllBooks :: ClientM [Book] +(getAllBooks :<|> postNewBook) = client myApi + + +main :: IO () +main = do + manager' <- newManager defaultManagerSettings + res <- runClientM getAllBooks (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right books -> print books +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,14 +7,35 @@ ## Example ``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Proxy +import Data.Text +import Network.HTTP.Client (newManager, defaultManagerSettings) +import Servant.API +import Servant.Client + + +type Book = Text + type MyApi = "books" :> Get '[JSON] [Book] -- GET /books - :<|> "books" :> ReqBody Book :> Post '[JSON] Book -- POST /books + :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books myApi :: Proxy MyApi myApi = Proxy -getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book] -postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book -- 'client' allows you to produce operations to query an API from a client. +postNewBook :: Book -> ClientM Book +getAllBooks :: ClientM [Book] (getAllBooks :<|> postNewBook) = client myApi + + +main :: IO () +main = do + manager' <- newManager defaultManagerSettings + res <- runClientM getAllBooks (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right books -> print books ``` 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.13.0.1 +version: 0.14 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -17,11 +17,11 @@ build-type: Simple cabal-version: >=1.10 tested-with: - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.2, - GHC==8.2.2, - GHC==8.4.1 + GHC==7.8.4 + GHC==7.10.3 + GHC==8.0.2 + GHC==8.2.2 + GHC==8.4.3 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: @@ -51,28 +51,25 @@ , transformers >= 0.3.0.0 && < 0.6 if !impl(ghc >= 8.0) - build-depends: semigroups >=0.18.3 && <0.19 + build-depends: semigroups >=0.18.4 && <0.19 -- Servant dependencies build-depends: - servant-client-core == 0.13.* + servant-client-core == 0.14.* -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - aeson >= 1.2.3.0 && < 1.4 - , base-compat >= 0.9.3 && < 0.11 - , attoparsec >= 0.13.2.0 && < 0.14 - , http-client >= 0.5.7.1 && < 0.6 - , http-client-tls >= 0.3.5.1 && < 0.4 - , http-media >= 0.7.0 && < 0.8 - , http-types >= 0.12 && < 0.13 - , exceptions >= 0.8.3 && < 0.11 - , monad-control >= 1.0.0.4 && < 1.1 - , semigroupoids >= 5.2.1 && < 5.3 - , stm >= 2.4.4.1 && < 2.5 - , transformers-base >= 0.4.4 && < 0.5 - , transformers-compat >= 0.5.1 && < 0.7 + base-compat >= 0.10.1 && < 0.11 + , http-client >= 0.5.12 && < 0.6 + , http-media >= 0.7.1.2 && < 0.8 + , http-types >= 0.12.1 && < 0.13 + , exceptions >= 0.10.0 && < 0.11 + , monad-control >= 1.0.2.3 && < 1.1 + , semigroupoids >= 5.2.2 && < 5.3 + , stm >= 2.4.5.0 && < 2.5 + , transformers-base >= 0.4.5.2 && < 0.5 + , transformers-compat >= 0.6.2 && < 0.7 hs-source-dirs: src default-language: Haskell2010 @@ -83,7 +80,7 @@ test-suite spec type: exitcode-stdio-1.0 - ghc-options: -Wall + ghc-options: -Wall -rtsopts -with-rtsopts=-T default-language: Haskell2010 hs-source-dirs: test main-is: Spec.hs @@ -97,10 +94,8 @@ , aeson , base-compat , bytestring - , containers , http-api-data , http-client - , http-media , http-types , mtl , servant-client @@ -117,14 +112,21 @@ -- Additonal dependencies build-depends: - deepseq >= 1.3.0.2 && < 1.5 - , generics-sop >= 0.3.1.0 && < 0.4 - , hspec >= 2.4.4 && < 2.6 - , HUnit >= 1.6 && < 1.7 - , network >= 2.6.3.2 && < 2.7 - , QuickCheck >= 2.10.1 && < 2.12 - , servant == 0.13.* - , servant-server == 0.13.* + generics-sop >= 0.3.2.0 && < 0.4 + , hspec >= 2.5.1 && < 2.6 + , HUnit >= 1.6 && < 1.7 + , network >= 2.6.3.2 && < 2.8 + , QuickCheck >= 2.10.1 && < 2.12 + , servant == 0.14.* + , servant-server == 0.14.* build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.6 + hspec-discover:hspec-discover >= 2.5.1 && < 2.6 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + build-depends: base, servant, http-client, text, servant-client, markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit + ghc-options: -pgmL markdown-unlit + default-language: Haskell2010 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -9,6 +9,7 @@ , runClientM , ClientEnv(..) , mkClientEnv + , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/src/Servant/Client/Internal/HttpClient.hs b/src/Servant/Client/Internal/HttpClient.hs --- a/src/Servant/Client/Internal/HttpClient.hs +++ b/src/Servant/Client/Internal/HttpClient.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Servant.Client.Internal.HttpClient where @@ -70,6 +71,28 @@ client :: HasClient ClientM api => Proxy api -> Client ClientM api client api = api `clientIn` (Proxy :: Proxy ClientM) +-- | Change the monad the client functions live in, by +-- supplying a conversion function +-- (a natural transformation to be precise). +-- +-- For example, assuming you have some @manager :: 'Manager'@ and +-- @baseurl :: 'BaseUrl'@ around: +-- +-- > type API = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int +-- > api :: Proxy API +-- > api = Proxy +-- > getInt :: IO Int +-- > postInt :: Int -> IO Int +-- > getInt :<|> postInt = hoistClient api (flip runClientM cenv) (client api) +-- > where cenv = mkClientEnv manager baseurl +hoistClient + :: HasClient ClientM api + => Proxy api + -> (forall a. m a -> n a) + -> Client m api + -> Client n api +hoistClient = hoistClientMonad (Proxy :: Proxy ClientM) + -- | @ClientM@ is the monad in which client functions run. Contains the -- 'Client.Manager' and 'BaseUrl' used for requests in the reader environment. newtype ClientM a = ClientM @@ -96,7 +119,6 @@ runRequest = performRequest streamingRequest = performStreamingRequest throwServantError = throwError - catchServantError = catchError instance ClientLike (ClientM a) (ClientM a) where mkClient = id @@ -184,10 +206,18 @@ where hs = toList $ requestAccept r + convertBody bd = case bd of + RequestBodyLBS body' -> Client.RequestBodyLBS body' + RequestBodyBS body' -> Client.RequestBodyBS body' + RequestBodyBuilder size body' -> Client.RequestBodyBuilder size body' + RequestBodyStream size body' -> Client.RequestBodyStream size body' + RequestBodyStreamChunked body' -> Client.RequestBodyStreamChunked body' + RequestBodyIO body' -> Client.RequestBodyIO (convertBody <$> body') + (body, contentTypeHdr) = case requestBody r of Nothing -> (Client.RequestBodyLBS "", Nothing) - Just (RequestBodyLBS body', typ) - -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ)) + Just (body', typ) + -> (convertBody body', Just (hContentType, renderHeader typ)) isSecure = case baseUrlScheme burl of Http -> False diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -90,6 +90,7 @@ basicAuthSpec genAuthSpec genericClientSpec + hoistClientSpec -- * test data types @@ -104,6 +105,9 @@ instance ToForm Person instance FromForm Person +instance Arbitrary Person where + arbitrary = Person <$> arbitrary <*> arbitrary + alice :: Person alice = Person "Alice" 42 @@ -488,6 +492,28 @@ left show <$> runClient (idChar (Just 'c')) baseUrl `shouldReturn` Right 'c' left show <$> runClient (getSum 3 4) baseUrl `shouldReturn` Right 7 left show <$> runClient doNothing baseUrl `shouldReturn` Right () + +-- * hoistClient + +type HoistClientAPI = Get '[JSON] Int :<|> Capture "n" Int :> Post '[JSON] Int + +hoistClientAPI :: Proxy HoistClientAPI +hoistClientAPI = Proxy + +hoistClientServer :: Application -- implements HoistClientAPI +hoistClientServer = serve hoistClientAPI $ return 5 :<|> (\n -> return n) + +hoistClientSpec :: Spec +hoistClientSpec = beforeAll (startWaiApp hoistClientServer) $ afterAll endWaiApp $ do + describe "Servant.Client.hoistClient" $ do + it "allows us to GET/POST/... requests in IO instead of ClientM" $ \(_, baseUrl) -> do + let (getInt :<|> postInt) + = hoistClient hoistClientAPI + (fmap (either (error . show) id) . flip runClient baseUrl) + (client hoistClientAPI) + + getInt `shouldReturn` 5 + postInt 5 `shouldReturn` 5 -- * utils diff --git a/test/Servant/StreamSpec.hs b/test/Servant/StreamSpec.hs --- a/test/Servant/StreamSpec.hs +++ b/test/Servant/StreamSpec.hs @@ -26,26 +26,32 @@ #include "overlapping-compat.h" module Servant.StreamSpec (spec) where -import Prelude () -import Prelude.Compat +import Control.Monad (replicateM_, void) +import qualified Data.ByteString as BS import Data.Proxy -import qualified Network.HTTP.Client as C -import System.IO.Unsafe (unsafePerformIO) +import qualified Network.HTTP.Client as C +import Prelude () +import Prelude.Compat +import System.IO (IOMode (ReadMode), withFile) +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec +import Test.QuickCheck -import Servant.API ((:<|>) ((:<|>)), - (:>), - EmptyAPI, JSON, - StreamGet, - NewlineFraming, - NetstringFraming, - ResultStream(..), - StreamGenerator(..)) +import Servant.API ((:<|>) ((:<|>)), (:>), JSON, + NetstringFraming, NewlineFraming, + OctetStream, ResultStream (..), + StreamGenerator (..), StreamGet, + NoFraming) import Servant.Client +import Servant.ClientSpec (Person (..)) +import qualified Servant.ClientSpec as CS import Servant.Server -import qualified Servant.ClientSpec as CS -import Servant.ClientSpec (Person(..)) +#if MIN_VERSION_base(4,10,0) +import GHC.Stats (gcdetails_mem_in_use_bytes, gc, getRTSStats) +#else +import GHC.Stats (currentBytesUsed, getGCStats) +#endif spec :: Spec spec = describe "Servant.Stream" $ do @@ -54,7 +60,7 @@ type StreamApi f = "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) - :<|> EmptyAPI + :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString) capi :: Proxy (StreamApi ResultStream) @@ -63,12 +69,9 @@ sapi :: Proxy (StreamApi StreamGenerator) sapi = Proxy - -getGetNL :<|> getGetNS :<|> EmptyClient = client capi - - -getGetNL :: ClientM (ResultStream Person) -getGetNS :: ClientM (ResultStream Person) +getGetNL, getGetNS :: ClientM (ResultStream Person) +getGetALot :: ClientM (ResultStream BS.ByteString) +getGetNL :<|> getGetNS :<|> getGetALot = client capi alice :: Person alice = Person "Alice" 42 @@ -77,16 +80,26 @@ bob = Person "Bob" 25 server :: Application -server = serve sapi ( - (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :: Handler (StreamGenerator Person)) - :<|> - (return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) - :: Handler (StreamGenerator Person)) - :<|> - emptyServer) +server = serve sapi + $ return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :<|> return (StreamGenerator (\f r -> f alice >> r bob >> r alice)) + :<|> return (StreamGenerator lotsGenerator) + where + lotsGenerator f r = do + void $ f "" + void $ withFile "/dev/urandom" ReadMode $ + \handle -> streamFiveMBNTimes handle 1000 r + return () + streamFiveMBNTimes handle left sink + | left <= (0 :: Int) = return () + | otherwise = do + msg <- BS.hGet handle (megabytes 5) + _ <- sink msg + streamFiveMBNTimes handle (left - 1) sink + + {-# NOINLINE manager' #-} manager' :: C.Manager manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings @@ -94,20 +107,39 @@ runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a) runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl') -runResultStream :: ResultStream a -> IO (Maybe (Either String a), Maybe (Either String a), Maybe (Either String a), Maybe (Either String a)) -runResultStream (ResultStream k) = k $ \act -> (,,,) <$> act <*> act <*> act <*> act +runResultStream :: ResultStream a + -> IO ( Maybe (Either String a) + , Maybe (Either String a) + , Maybe (Either String a) + , Maybe (Either String a)) +runResultStream (ResultStream k) + = k $ \act -> (,,,) <$> act <*> act <*> act <*> act streamSpec :: Spec streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do - it "Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do + it "works with Servant.API.StreamGet.Newline" $ \(_, baseUrl) -> do Right res <- runClient getGetNL baseUrl let jra = Just (Right alice) jrb = Just (Right bob) runResultStream res `shouldReturn` (jra, jrb, jra, Nothing) - it "Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do + it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do Right res <- runClient getGetNS baseUrl let jra = Just (Right alice) jrb = Just (Right bob) runResultStream res `shouldReturn` (jra, jrb, jra, Nothing) + + it "streams in constant memory" $ \(_, baseUrl) -> do + Right (ResultStream res) <- runClient getGetALot baseUrl + let consumeNChunks n = replicateM_ n (res void) + consumeNChunks 900 +#if MIN_VERSION_base(4,10,0) + memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats +#else + memUsed <- currentBytesUsed <$> getGCStats +#endif + memUsed `shouldSatisfy` (< megabytes 22) + +megabytes :: Num a => a -> a +megabytes n = n * (1000 ^ (2 :: Int))