requestBodySourceIO from http-conduit is not GivesPopper-safe

[thomasjm]

The requestBodySourceIO function uses the RequestBodyStream constructor (see here), but doesn't satisfy the required contract ("you must ensure that the GivesPopper can be called multiple times").

As a result, if http-client needs to retry the request and re-evaluate the request body, you get an exception: WrongRequestBodyStreamSize N 0, where N is the original body size.

Retries are a normal part of HTTP. One situation where a retry may occur is when a persistent connection has become stale. The repro below shows an example of this. (Based on the one originally provided here by @matil019--it can be run with the Stack shebang.)

Note: I believe all the requestBody* functions from http-conduit are affected by this.

#!/usr/bin/env stack
-- stack script --resolver lts-16.20
{-# LANGUAGE OverloadedStrings #-}

import qualified Conduit as C
import Control.Concurrent (threadDelay)
import qualified Data.ByteString.Lazy.Char8 as L8
import Network.HTTP.Client
import Network.HTTP.Conduit (requestBodySourceIO)
import Network.HTTP.Types.Status (statusCode)
import System.IO
import System.IO.Temp

main :: IO ()
main = do
  manager <- newManager defaultManagerSettings

  -- Send an initial request, which will succeed and leave a persistent connection open
  doRequest manager

  -- Sleep for 6 seconds. The server will send a FIN after 5 seconds, causing
  -- the connection to become stale.
  putStrLn $ "Sleeping for 6 seconds"
  threadDelay (6 * 1000 * 1000)

  -- A subsequent request will cause a re-evaluation of the request body, which will fail
  doRequest manager

doRequest manager = do
  path <- writeSystemTempFile "foo.json" "{ \"a\": 1 }"
  C.withSourceFile path $ \f -> do
    initialRequest <- parseRequest "http://scooterlabs.com/echo"
    let request = initialRequest {
          method = "POST"
          , requestBody = requestBodySourceIO 10 f
          , requestHeaders = [("Content-Type", "application/json; charset=utf-8")]
         }

    response <- httpLbs request manager
    putStrLn $ "The status code was: " ++ show (statusCode $ responseStatus response)
    L8.putStrLn $ responseBody response