diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Req Conduit 0.1.0 + +* Initial release. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2016 Mark Karpov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name Mark Karpov nor the names of contributors may be used to + endorse or promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Req/Conduit.hs b/Network/HTTP/Req/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Req/Conduit.hs @@ -0,0 +1,165 @@ +-- | +-- Module : Network.HTTP.Req.Conduit +-- Copyright : © 2016 Mark Karpov, Michael Snoyman +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- The module extends functionality available in "Network.HTTP.Req" with +-- Conduit helpers for streaming big request bodies. +-- +-- The package re-uses some pieces of code from the @http-conduit@ package, +-- but not to the extent that depending on that package is reasonable. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE ConstraintKinds #-} +#endif + +module Network.HTTP.Req.Conduit + ( -- * Streaming request bodies + ReqBodySource (..) + -- * Streaming response bodies + -- $streaming-response + , req' + , httpSource ) +where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadResource (..)) +import Data.ByteString (ByteString) +import Data.Conduit (Source, ($$+), ($$++), await, yield) +import Data.IORef +import Data.Int (Int64) +import Network.HTTP.Req +import qualified Data.ByteString as B +import qualified Data.Conduit as C +import qualified Network.HTTP.Client as L + +---------------------------------------------------------------------------- +-- Request bodies + +-- | This body option streams contents of request body from given +-- 'C.Source'. The 'Int64' value is size of the data in bytes. +-- +-- Using of this body option does not set the @Content-Type@ header. + +data ReqBodySource = ReqBodySource Int64 (C.Source IO ByteString) + +instance HttpBody ReqBodySource where + getRequestBody (ReqBodySource size src) = + L.RequestBodyStream size (srcToPopperIO src) + +---------------------------------------------------------------------------- +-- Response interpretations + +-- $streaming-response +-- +-- Streaming response is a bit tricky as acquiring and releasing a resource +-- (initiating a connection and then closing it in our case) in context of +-- @conduit@ streaming requires working with +-- 'Control.Monad.Trans.Resource.ResourceT' monad transformer. This does not +-- play well with the framework @req@ builds. +-- +-- Essentially there are only two ways to make it work: +-- +-- * Require that every 'MonadHttp' must be an instance of +-- 'MonadResource'. This obviously makes the @req@ package harder to +-- work with and less user-friendly. Not to mention that most of the +-- time the instance won't be necessary. +-- * Use the 'withReqManager' in combination with 'ReturnRequest' +-- response interpretation to get both 'L.Manager' and 'L.Request' and +-- then delegate the work to to a custom callback. +-- +-- We go with the second option. Here is an example of how to stream 100000 +-- bytes and save them to a file: +-- +-- > {-# LANGUAGE FlexibleInstances #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import Control.Exception (throwIO) +-- > import Control.Monad.IO.Class (MonadIO (..)) +-- > import Control.Monad.Trans.Resource (ResourceT) +-- > import Data.Conduit ((=$=), runConduitRes, ConduitM) +-- > import Network.HTTP.Req +-- > import Network.HTTP.Req.Conduit +-- > import qualified Data.Conduit.Binary as CB +-- > +-- > instance MonadHttp (ConduitM i o (ResourceT IO)) where +-- > handleHttpException = liftIO . throwIO +-- > +-- > main :: IO () +-- > main = runConduitRes $ do +-- > let size = 100000 :: Int +-- > req' GET (https "httpbin.org" /: "bytes" /~ size) NoReqBody httpSource mempty +-- > =$= CB.sinkFile "my-favorite-file.bin" + +-- | Mostly like 'req' with respect to its arguments, but instead of a hint +-- how to interpret response it takes a callback that allows to perform a +-- request using arbitrary code. + +req' + :: ( MonadHttp m + , HttpMethod method + , HttpBody body + , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) ) + => method -- ^ HTTP method + -> Url scheme -- ^ 'Url' — location of resource + -> body -- ^ Body of the request + -> (L.Request -> L.Manager -> m a) -- ^ How to perform actual request + -> Option scheme -- ^ Collection of optional parameters + -> m a -- ^ Result +req' method url body m options = do + request <- responseRequest `liftM` req method url body returnRequest options + withReqManager (m request) + +-- | Perform an HTTP request and get the response as a 'C.Producer'. + +httpSource + :: MonadResource m + => L.Request -- ^ Pre-formed 'L.Request' + -> L.Manager -- ^ Manger to use + -> C.Producer m ByteString -- ^ Response body as a 'C.Producer' +httpSource request manager = + C.bracketP (L.responseOpen request manager) L.responseClose + (bodyReaderSource . L.responseBody) + +---------------------------------------------------------------------------- +-- Helpers + +-- | This is taken from "Network.HTTP.Client.Conduit" without modifications. + +srcToPopperIO :: Source IO ByteString -> L.GivesPopper () +srcToPopperIO src f = do + (rsrc0, ()) <- src $$+ return () + irsrc <- newIORef rsrc0 + let popper :: IO ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- rsrc $$++ await + writeIORef irsrc rsrc' + case mres of + Nothing -> return B.empty + Just bs + | B.null bs -> popper + | otherwise -> return bs + f popper + +-- | This is taken from "Network.HTTP.Client.Conduit" without modifications. + +bodyReaderSource :: MonadIO m => L.BodyReader -> C.Producer m ByteString +bodyReaderSource br = go + where + go = do + bs <- liftIO (L.brRead br) + unless (B.null bs) $ do + yield bs + go diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# Req Conduit + +[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) +[![Hackage](https://img.shields.io/hackage/v/req-conduit.svg?style=flat)](https://hackage.haskell.org/package/req-conduit) +[![Stackage Nightly](http://stackage.org/package/req-conduit/badge/nightly)](http://stackage.org/nightly/package/req-conduit) +[![Stackage LTS](http://stackage.org/package/req-conduit/badge/lts)](http://stackage.org/lts/package/req-conduit) +[![Build Status](https://travis-ci.org/mrkkrp/req-conduit.svg?branch=master)](https://travis-ci.org/mrkkrp/req-conduit) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/req-conduit/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/req-conduit?branch=master) + +This library extends functionality of +the [`req`](https://hackage.haskell.org/package/req) package +with [`conduit`](https://hackage.haskell.org/package/conduit) helpers for +streaming big request bodies in constant space. + +## Potential issues + +Streaming of request body does not happen in constant memory. But it does +not work with `http-conduit` either, see: +https://github.com/snoyberg/http-client/issues/240. Streaming of response +body does happen in constant memory as expected. See the benchmarks coming +with the library for hands-on experiences. + +## Contribution + +Issues, bugs, and questions may be reported in [the GitHub issue tracker for +this project](https://github.com/mrkkrp/req-conduit/issues). + +Pull requests are also welcome and will be reviewed quickly. + +## License + +Copyright © 2016 Mark Karpov, Micheal Snoyman + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/httpbin-tests/Network/HTTP/Req/ConduitSpec.hs b/httpbin-tests/Network/HTTP/Req/ConduitSpec.hs new file mode 100644 --- /dev/null +++ b/httpbin-tests/Network/HTTP/Req/ConduitSpec.hs @@ -0,0 +1,100 @@ +-- +-- Tests for ‘req-conduit’ package. This test suite tests streaming large +-- request and response bodies. +-- +-- Copyright © 2016 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- * Neither the name Mark Karpov nor the names of contributors may be used +-- to endorse or promote products derived from this software without +-- specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.HTTP.Req.ConduitSpec + ( spec ) +where + +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Conduit ((=$=), runConduitRes, ConduitM) +import Data.Int (Int64) +import Network.HTTP.Req +import Network.HTTP.Req.Conduit +import System.IO (Handle) +import System.IO.Temp +import Test.Hspec +import qualified Data.ByteString as B +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +spec :: Spec +spec = do + + describe "streaming 100 M request" $ + it "works" $ do + let size :: Int64 + size = 100 * 1024 * 1024 + src = CL.replicate (100 * 1024) (B.replicate 1024 0) + void (req POST (httpbin /: "post") + (ReqBodySource size src) ignoreResponse mempty) :: IO () + + describe "streaming 100 M response" $ + it "works" $ do + let tempi :: (Handle -> IO ()) -> IO () + tempi f = withSystemTempFile "req-conduit" (const f) + tempi $ \h -> + runConduitRes $ do + let size :: Int + size = 100 * 1024 * 1024 + req' GET (httpbin /: "stream-bytes" /~ size) NoReqBody + httpSource mempty =$= CB.sinkHandle h + +---------------------------------------------------------------------------- +-- Instances + +instance MonadHttp IO where + handleHttpException = throwIO + +instance MonadHttp (ConduitM i o (ResourceT IO)) where + handleHttpException = liftIO . throwIO + +---------------------------------------------------------------------------- +-- Helpers + +-- | 'Url' representing . + +httpbin :: Url 'Https +httpbin = https "httpbin.org" diff --git a/httpbin-tests/Spec.hs b/httpbin-tests/Spec.hs new file mode 100644 --- /dev/null +++ b/httpbin-tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/req-conduit.cabal b/req-conduit.cabal new file mode 100644 --- /dev/null +++ b/req-conduit.cabal @@ -0,0 +1,111 @@ +-- +-- Cabal configuration for ‘req-conduit’ package. +-- +-- Copyright © 2016 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- * Neither the name Mark Karpov nor the names of contributors may be used +-- to endorse or promote products derived from this software without +-- specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. + +name: req-conduit +version: 0.1.0 +cabal-version: >= 1.10 +license: BSD3 +license-file: LICENSE.md +author: Mark Karpov , Michael Snoyman +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/req-conduit +bug-reports: https://github.com/mrkkrp/req-conduit/issues +category: Network, Web, Conduit +synopsis: Conduit helpers for the req HTTP client library +build-type: Simple +description: Conduit helpers for the req HTTP client library. +extra-doc-files: CHANGELOG.md + , README.md + +source-repository head + type: git + location: https://github.com/mrkkrp/req-conduit.git + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , conduit >= 0.5.5 && < 1.3 + , http-client >= 0.5 && < 0.6 + , req >= 0.1 && < 0.2 + , resourcet >= 1.1 && < 1.2 + , transformers >= 0.4 && < 0.6 + exposed-modules: Network.HTTP.Req.Conduit + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite httpbin-tests + main-is: Spec.hs + other-modules: Network.HTTP.Req.ConduitSpec + hs-source-dirs: httpbin-tests + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , conduit >= 0.5.5 && < 1.3 + , conduit-extra >= 1.1.10 && < 1.2 + , hspec >= 2.0 && < 3.0 + , req >= 0.1 && < 0.2 + , req-conduit >= 0.1.0 + , resourcet >= 1.1 && < 1.2 + , temporary >= 1.1 && < 1.3 + , transformers >= 0.4 && < 0.6 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +benchmark weigh-bench + main-is: Main.hs + hs-source-dirs: weigh-bench + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.2 && < 0.11 + , conduit >= 0.5.5 && < 1.3 + , conduit-extra >= 1.1.10 && < 1.2 + , req >= 0.1 && < 0.2 + , req-conduit >= 0.1.0 + , resourcet >= 1.1 && < 1.2 + , temporary >= 1.1 && < 1.3 + , weigh >= 0.0.3 + if flag(dev) + ghc-options: -O2 -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 diff --git a/weigh-bench/Main.hs b/weigh-bench/Main.hs new file mode 100644 --- /dev/null +++ b/weigh-bench/Main.hs @@ -0,0 +1,94 @@ +-- +-- Space-consumption benchmark for ‘req-conduit’. +-- +-- Copyright © 2016 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- * Neither the name Mark Karpov nor the names of contributors may be used +-- to endorse or promote products derived from this software without +-- specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY +-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +-- POSSIBILITY OF SUCH DAMAGE. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (ResourceT) +import Data.Conduit ((=$=), runConduitRes, ConduitM) +import Data.Int (Int64) +import Network.HTTP.Req +import Network.HTTP.Req.Conduit +import System.IO.Temp +import Weigh +import qualified Data.ByteString as B +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +main :: IO () +main = mainWith $ do + io "streaming 5 M request body" bigRequest (5 * 1024 * 1024) + io "streaming 25 M request body" bigRequest (25 * 1024 * 1024) + io "streaming 50 M request body" bigRequest (50 * 1024 * 1024) + io "streaming 100 M request body" bigRequest (100 * 1024 * 1024) + io "streaming 5 M response body" bigResponse (5 * 1024 * 1024) + io "streaming 25 M response body" bigResponse (25 * 1024 * 1024) + io "streaming 50 M response body" bigResponse (50 * 1024 * 1024) + io "streaming 100 M response body" bigResponse (100 * 1024 * 1024) + +bigRequest :: Int64 -> IO () +bigRequest size' = do + let size = (size' `quot` 1024) * 1024 + chunk = B.replicate 1024 0 + let src = CL.replicate (fromIntegral size `quot` 1024) chunk + void $ req POST (httpbin /: "post") + (ReqBodySource size src) ignoreResponse mempty + +bigResponse :: Int -> IO () +bigResponse size = withSystemTempFile "req-conduit" $ \_ h -> + runConduitRes $ + req' GET (httpbin /: "stream-bytes" /~ size) NoReqBody + httpSource mempty =$= CB.sinkHandle h + +---------------------------------------------------------------------------- +-- Instances + +instance MonadHttp IO where + handleHttpException = throwIO + +instance MonadHttp (ConduitM i o (ResourceT IO)) where + handleHttpException = liftIO . throwIO + +---------------------------------------------------------------------------- +-- Helpers + +-- | 'Url' representing . + +httpbin :: Url 'Https +httpbin = https "httpbin.org"