Network stackclient refactor (#4119)

.hlint.yaml

@@ -45,12 +45,47 @@
 - ignore: {name: "Use display", within: "warnMultiple"}
 - ignore: {name: "Use display", within: "Stack.PrettyPrint"}
 
+- error: {lhs: "Network.HTTP.Client.MultipartFormData.formDataBody", rhs: "Network.HTTP.StackClient.formDataBody"}
+- error: {lhs: "Network.HTTP.Client.MultipartFormData.partBS", rhs: "Network.HTTP.StackClient.partBS"}
+- error: {lhs: "Network.HTTP.Client.MultipartFormData.partFileRequestBody", rhs: "Network.HTTP.StackClient.partFileRequestBody"}
+- error: {lhs: "Network.HTTP.Client.MultipartFormData.partLBS", rhs: "Network.HTTP.StackClient.partLBS"}
+- error: {lhs: "Network.HTTP.Client.Request.setUri", rhs: "Network.HTTP.StackClient.setUri"}
+- error: {lhs: "Network.HTTP.Client.TLS.applyDigestAuth", rhs: "Network.HTTP.StackClient.applyDigestAuth"}
+- error: {lhs: "Network.HTTP.Client.TLS.displayDigestAuthException", rhs: "Network.HTTP.StackClient.displayDigestAuthException"}
+- error: {lhs: "Network.HTTP.Client.TLS.getGlobalManager", rhs: "Network.HTTP.StackClient.getGlobalManager"}
+- error: {lhs: "Network.HTTP.Client.checkResponse", rhs: "Network.HTTP.StackClient.checkResponse"}
+- error: {lhs: "Network.HTTP.Client.getUri", rhs: "Network.HTTP.StackClient.getUri"}
+- error: {lhs: "Network.HTTP.Client.parseRequest", rhs: "Network.HTTP.StackClient.parseRequest"}
+- error: {lhs: "Network.HTTP.Client.parseRequest_", rhs: "Network.HTTP.StackClient.parseRequest_"}
+- error: {lhs: "Network.HTTP.Client.parseUrlThrow", rhs: "Network.HTTP.StackClient.parseUrlThrow"}
+- error: {lhs: "Network.HTTP.Client.path", rhs: "Network.HTTP.StackClient.path"}
+- error: {lhs: "Network.HTTP.Client.responseHeaders", rhs: "Network.HTTP.StackClient.responseHeaders"}
+- error: {lhs: "Network.HTTP.Client.withResponse", rhs: "Network.HTTP.StackClient.withResponseByManager"}
+- error: {lhs: "Network.HTTP.Conduit.requestHeaders", rhs: "Network.HTTP.StackClient.requestHeaders"}
+- error: {lhs: "Network.HTTP.Simple.HttpException", rhs: "Network.HTTP.StackClient.HttpException"}
+- error: {lhs: "Network.HTTP.Simple.addRequestHeader", rhs: "Network.HTTP.StackClient.addRequestHeader"}
+- error: {lhs: "Network.HTTP.Simple.getResponseBody", rhs: "Network.HTTP.StackClient.getResponseBody"}
+- error: {lhs: "Network.HTTP.Simple.getResponseHeaders", rhs: "Network.HTTP.StackClient.getResponseHeaders"}
+- error: {lhs: "Network.HTTP.Simple.getResponseStatusCode", rhs: "Network.HTTP.StackClient.getResponseStatusCode"}
 - error: {lhs: "Network.HTTP.Simple.httpJSON", rhs: "Network.HTTP.StackClient.httpJSON"}
-- error: {lhs: "Network.HTTP.Simple.httpLbs", rhs: "Network.HTTP.StackClient.httpLbs"}
 - error: {lhs: "Network.HTTP.Simple.httpLBS", rhs: "Network.HTTP.StackClient.httpLBS"}
-- error: {lhs: "Network.HTTP.Simple.httpSink", rhs: "Network.HTTP.StackClient.httpSink"}
+- error: {lhs: "Network.HTTP.Simple.httpLbs", rhs: "Network.HTTP.StackClient.httpLbs"}
 - error: {lhs: "Network.HTTP.Simple.httpNoBody", rhs: "Network.HTTP.StackClient.httpNoBody"}
+- error: {lhs: "Network.HTTP.Simple.httpSink", rhs: "Network.HTTP.StackClient.httpSink"}
+- error: {lhs: "Network.HTTP.Simple.setRequestBody", rhs: "Network.HTTP.StackClient.getRequestBody"}
+- error: {lhs: "Network.HTTP.Simple.setRequestHeader", rhs: "Network.HTTP.StackClient.setRequestHeader"}
+- error: {lhs: "Network.HTTP.Simple.setRequestManager", rhs: "Network.HTTP.StackClient.setRequestManager"}
+- error: {lhs: "Network.HTTP.Simple.setRequestMethod", rhs: "Network.HTTP.StackClient.getRequestMethod"}
 - error: {lhs: "Network.HTTP.Simple.withResponse", rhs: "Network.HTTP.StackClient.withResponse"}
-- error: {lhs: "Network.HTTP.Client.withResponse", rhs: "Network.HTTP.StackClient.withResponseByManager"}
+- error: {lhs: "Network.HTTP.Types.Header", rhs: "Network.HTTP.StackClient.Header"}
+- error: {lhs: "Network.HTTP.Types.HeaderName", rhs: "Network.HTTP.StackClient.HeaderName"}
+- error: {lhs: "Network.HTTP.Types.Manager", rhs: "Network.HTTP.StackClient.Manager"}
+- error: {lhs: "Network.HTTP.Types.Request", rhs: "Network.HTTP.StackClient.Request"}
+- error: {lhs: "Network.HTTP.Types.RequestBody", rhs: "Network.HTTP.StackClient.RequestBody"}
+- error: {lhs: "Network.HTTP.Types.Response", rhs: "Network.HTTP.StackClient.Response"}
+- error: {lhs: "Network.HTTP.Types.hAccept", rhs: "Network.HTTP.StackClient.hAccept"}
+- error: {lhs: "Network.HTTP.Types.hContentLength", rhs: "Network.HTTP.StackClient.hContentLength"}
+- error: {lhs: "Network.HTTP.Types.hContentMD5", rhs: "Network.HTTP.StackClient.hContentMD5"}
+- error: {lhs: "Network.HTTP.Types.methodPut", rhs: "Network.HTTP.StackClient.methodPut"}
 - ignore: {name: "Use alternative", within: "Network.HTTP.StackClient"}
 - ignore: {name: "Use withResponseByManager", within: "Network.HTTP.StackClient"}

src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs

@@ -7,8 +7,7 @@
 -- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client
 -- to avoid extra dependencies
 module Hackage.Security.Client.Repository.HttpLib.HttpClient (
-    withClient
-  , makeHttpLib
+    makeHttpLib
     -- ** Re-exports
   , Manager -- opaque
   ) where
@@ -17,13 +16,10 @@ import Control.Exception
 import Control.Monad (void)
 import Data.ByteString (ByteString)
 import Network.URI
-import Network.HTTP.Client (Manager)
 import qualified Data.ByteString              as BS
 import qualified Data.ByteString.Char8        as BS.C8
-import qualified Network.HTTP.Client          as HttpClient
-import qualified Network.HTTP.Client.Internal as HttpClient
+import           Network.HTTP.StackClient (Manager)
 import qualified Network.HTTP.StackClient     as StackClient
-import qualified Network.HTTP.Types           as HttpClient
 
 import Hackage.Security.Client hiding (Header)
 import Hackage.Security.Client.Repository.HttpLib
@@ -34,21 +30,6 @@ import qualified Hackage.Security.Util.Lens as Lens
   Top-level API
 -------------------------------------------------------------------------------}
 
--- | Initialization
---
--- The proxy must be specified at initialization because @http-client@ does not
--- allow to change the proxy once the 'Manager' is created.
-withClient :: ProxyConfig HttpClient.Proxy -> (Manager -> HttpLib -> IO a) -> IO a
-withClient proxyConfig callback = do
-    manager <- HttpClient.newManager (setProxy HttpClient.defaultManagerSettings)
-    callback manager $ makeHttpLib manager
-  where
-    setProxy = HttpClient.managerSetProxy $
-      case proxyConfig of
-        ProxyConfigNone  -> HttpClient.noProxy
-        ProxyConfigUse p -> HttpClient.useProxy p
-        ProxyConfigAuto  -> HttpClient.proxyEnvironment Nothing
-
 -- | Create an 'HttpLib' value from a preexisting 'Manager'.
 makeHttpLib :: Manager -> HttpLib
 makeHttpLib manager = HttpLib
@@ -68,10 +49,10 @@ get :: Throws SomeRemoteError
 get manager reqHeaders uri callback = wrapCustomEx $ do
     -- TODO: setUri fails under certain circumstances; in particular, when
     -- the URI contains URL auth. Not sure if this is a concern.
-    request' <- HttpClient.setUri HttpClient.defaultRequest uri
+    request' <- StackClient.setUri StackClient.defaultRequest uri
     let request = setRequestHeaders reqHeaders request'
     checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
-      let br = wrapCustomEx $ HttpClient.responseBody response
+      let br = wrapCustomEx $ StackClient.responseBody response
       callback (getResponseHeaders response) br
 
 getRange :: Throws SomeRemoteError
@@ -80,49 +61,49 @@ getRange :: Throws SomeRemoteError
          -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
          -> IO a
 getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do
-    request' <- HttpClient.setUri HttpClient.defaultRequest uri
+    request' <- StackClient.setUri StackClient.defaultRequest uri
     let request = setRange from to
                 $ setRequestHeaders reqHeaders request'
     checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do
-      let br = wrapCustomEx $ HttpClient.responseBody response
+      let br = wrapCustomEx $ StackClient.responseBody response
       case () of
-         () | HttpClient.responseStatus response == HttpClient.partialContent206 ->
+         () | StackClient.responseStatus response == StackClient.partialContent206 ->
            callback HttpStatus206PartialContent (getResponseHeaders response) br
-         () | HttpClient.responseStatus response == HttpClient.ok200 ->
+         () | StackClient.responseStatus response == StackClient.ok200 ->
            callback HttpStatus200OK (getResponseHeaders response) br
          _otherwise ->
-           throwChecked $ HttpClient.HttpExceptionRequest request
-                        $ HttpClient.StatusCodeException (void response) ""
+           throwChecked $ StackClient.HttpExceptionRequest request
+                        $ StackClient.StatusCodeException (void response) ""
 
 -- | Wrap custom exceptions
 --
 -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@
 -- but it is currently disabled <https://github.com/snoyberg/http-client/issues/116>
-wrapCustomEx :: (Throws HttpClient.HttpException => IO a)
+wrapCustomEx :: (Throws StackClient.HttpException => IO a)
              -> (Throws SomeRemoteError => IO a)
-wrapCustomEx act = handleChecked (\(ex :: HttpClient.HttpException) -> go ex) act
+wrapCustomEx act = handleChecked (\(ex :: StackClient.HttpException) -> go ex) act
   where
     go ex = throwChecked (SomeRemoteError ex)
 
-checkHttpException :: Throws HttpClient.HttpException => IO a -> IO a
-checkHttpException = handle $ \(ex :: HttpClient.HttpException) ->
+checkHttpException :: Throws StackClient.HttpException => IO a -> IO a
+checkHttpException = handle $ \(ex :: StackClient.HttpException) ->
                        throwChecked ex
 
 {-------------------------------------------------------------------------------
   http-client auxiliary
 -------------------------------------------------------------------------------}
 
-hAcceptRanges :: HttpClient.HeaderName
+hAcceptRanges :: StackClient.HeaderName
 hAcceptRanges = "Accept-Ranges"
 
-hAcceptEncoding :: HttpClient.HeaderName
+hAcceptEncoding :: StackClient.HeaderName
 hAcceptEncoding = "Accept-Encoding"
 
 setRange :: Int -> Int
-         -> HttpClient.Request -> HttpClient.Request
+         -> StackClient.Request -> StackClient.Request
 setRange from to req = req {
-      HttpClient.requestHeaders = (HttpClient.hRange, rangeHeader)
-                                : HttpClient.requestHeaders req
+      StackClient.requestHeaders = (StackClient.hRange, rangeHeader)
+                                : StackClient.requestHeaders req
     }
   where
     -- Content-Range header uses inclusive rather than exclusive bounds
@@ -131,42 +112,42 @@ setRange from to req = req {
 
 -- | Set request headers
 setRequestHeaders :: [HttpRequestHeader]
-                  -> HttpClient.Request -> HttpClient.Request
+                  -> StackClient.Request -> StackClient.Request
 setRequestHeaders opts req = req {
-      HttpClient.requestHeaders = trOpt disallowCompressionByDefault opts
+      StackClient.requestHeaders = trOpt disallowCompressionByDefault opts
     }
   where
-    trOpt :: [(HttpClient.HeaderName, [ByteString])]
+    trOpt :: [(StackClient.HeaderName, [ByteString])]
           -> [HttpRequestHeader]
-          -> [HttpClient.Header]
+          -> [StackClient.Header]
     trOpt acc [] =
       concatMap finalizeHeader acc
     trOpt acc (HttpRequestMaxAge0:os) =
-      trOpt (insert HttpClient.hCacheControl ["max-age=0"] acc) os
+      trOpt (insert StackClient.hCacheControl ["max-age=0"] acc) os
     trOpt acc (HttpRequestNoTransform:os) =
-      trOpt (insert HttpClient.hCacheControl ["no-transform"] acc) os
+      trOpt (insert StackClient.hCacheControl ["no-transform"] acc) os
 
     -- disable content compression (potential security issue)
-    disallowCompressionByDefault :: [(HttpClient.HeaderName, [ByteString])]
+    disallowCompressionByDefault :: [(StackClient.HeaderName, [ByteString])]
     disallowCompressionByDefault = [(hAcceptEncoding, [])]
 
     -- Some headers are comma-separated, others need multiple headers for
     -- multiple options.
     --
     -- TODO: Right we we just comma-separate all of them.
-    finalizeHeader :: (HttpClient.HeaderName, [ByteString])
-                   -> [HttpClient.Header]
+    finalizeHeader :: (StackClient.HeaderName, [ByteString])
+                   -> [StackClient.Header]
     finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))]
 
     insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
     insert x y = Lens.modify (Lens.lookupM x) (++ y)
 
 -- | Extract the response headers
-getResponseHeaders :: HttpClient.Response a -> [HttpResponseHeader]
+getResponseHeaders :: StackClient.Response a -> [HttpResponseHeader]
 getResponseHeaders response = concat [
       [ HttpResponseAcceptRangesBytes
       | (hAcceptRanges, "bytes") `elem` headers
       ]
     ]
   where
-    headers = HttpClient.responseHeaders response
+    headers = StackClient.responseHeaders response

src/Network/HTTP/Download.hs

@@ -30,12 +30,8 @@ import           Data.Conduit                (yield)
 import qualified Data.Conduit.Binary         as CB
 import           Data.Text.Encoding.Error    (lenientDecode)
 import           Data.Text.Encoding          (decodeUtf8With)
-import           Network.HTTP.Client         (Request, Response, path, checkResponse, parseUrlThrow, parseRequest)
-import           Network.HTTP.Client.Conduit (requestHeaders)
 import           Network.HTTP.Download.Verified
-import           Network.HTTP.StackClient    (httpJSON, httpLbs, httpLBS, withResponse)
-import           Network.HTTP.Simple         (getResponseBody, getResponseHeaders, getResponseStatusCode,
-                                              setRequestHeader)
+import           Network.HTTP.StackClient    (Request, Response, httpJSON, httpLbs, httpLBS, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode)
 import           Path.IO                     (doesFileExist)
 import           System.Directory            (createDirectoryIfMissing,
                                               removeFile)

src/Network/HTTP/Download/Verified.hs

@@ -41,10 +41,7 @@ import              Data.Conduit.Binary (sourceHandle)
 import              Data.Text.Encoding (decodeUtf8With)
 import              Data.Text.Encoding.Error (lenientDecode)
 import              GHC.IO.Exception (IOException(..),IOErrorType(..))
-import              Network.HTTP.Client (getUri, path)
-import              Network.HTTP.StackClient (httpSink)
-import              Network.HTTP.Simple (Request, HttpException, getResponseHeaders)
-import              Network.HTTP.Types.Header (hContentLength, hContentMD5)
+import              Network.HTTP.StackClient (Request, HttpException, httpSink, getUri, path, getResponseHeaders, hContentLength, hContentMD5)
 import              Path
 import              Stack.Types.Runner
 import              Stack.PrettyPrint

src/Network/HTTP/StackClient.hs

@@ -13,6 +13,54 @@ module Network.HTTP.StackClient
   , setUserAgent
   , withResponse
   , withResponseByManager
+  , setRequestMethod
+  , setRequestHeader
+  , addRequestHeader
+  , setRequestBody
+  , setRequestManager
+  , getResponseHeaders
+  , getResponseBody
+  , getResponseStatusCode
+  , Network.HTTP.Client.responseHeaders
+  , Network.HTTP.Client.responseStatus
+  , Network.HTTP.Client.responseBody
+  , parseRequest
+  , parseRequest_
+  , defaultRequest
+  , setUri
+  , getUri
+  , path
+  , checkResponse
+  , parseUrlThrow
+  , requestHeaders
+  , getGlobalManager
+  , applyDigestAuth
+  , displayDigestAuthException
+  , Request
+  , RequestBody(RequestBodyBS, RequestBodyLBS)
+  , Response
+  , Manager
+  , Header
+  , HeaderName
+  , HttpException(HttpExceptionRequest)
+  , HttpExceptionContent(StatusCodeException)
+  , hAccept
+  , hContentLength
+  , hContentMD5
+  , hCacheControl
+  , hRange
+  , methodPut
+  , ok200
+  , partialContent206
+  , Proxy
+  , useProxy
+  , noProxy
+  , proxyEnvironment
+  , managerSetProxy
+  , formDataBody
+  , partFileRequestBody
+  , partBS
+  , partLBS
   ) where
 
 import           Data.Aeson (FromJSON)
@@ -21,9 +69,14 @@ import           Data.ByteString.Lazy (ByteString)
 import           Data.Conduit (ConduitM, transPipe)
 import           Data.Void (Void)
 import qualified Network.HTTP.Client
-import           Network.HTTP.Client (BodyReader, Manager, Request, Response)
-import           Network.HTTP.Simple (setRequestHeader)
+import           Network.HTTP.Client (BodyReader, Manager, Request, RequestBody(..), Response, Manager, HttpExceptionContent(..), parseRequest, parseRequest_, defaultRequest, getUri, path, checkResponse, parseUrlThrow, responseStatus, responseBody, useProxy, noProxy, proxyEnvironment, managerSetProxy, Proxy)
+import           Network.HTTP.Client.Internal (setUri)
+import           Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, setRequestManager, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders)
+import           Network.HTTP.Types (hAccept, hContentLength, hContentMD5, hCacheControl, hRange, methodPut, Header, HeaderName, ok200, partialContent206)
+import           Network.HTTP.Conduit (requestHeaders)
+import           Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException)
 import qualified Network.HTTP.Simple
+import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS)
 import           UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO)
 
 

src/Stack/Config.hs

@@ -65,9 +65,7 @@ import qualified Distribution.Text
 import           Distribution.Version (simplifyVersionRange, mkVersion')
 import           GHC.Conc (getNumProcessors)
 import           Lens.Micro (lens, set)
-import           Network.HTTP.Client (parseUrlThrow)
-import           Network.HTTP.StackClient (httpJSON)
-import           Network.HTTP.Simple (getResponseBody)
+import           Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
 import           Options.Applicative (Parser, strOption, long, help)
 import           Path
 import           Path.Extra (toFilePathNoTrailingSep)

src/Stack/Ls.hs

@@ -24,11 +24,8 @@ import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Typeable (Typeable)
 import qualified Data.Vector as V
-import Network.HTTP.StackClient (httpJSON)
-import Network.HTTP.Simple
-       (addRequestHeader, getResponseBody, parseRequest,
-        setRequestManager)
-import Network.HTTP.Types.Header (hAccept)
+import Network.HTTP.StackClient (httpJSON, getGlobalManager, addRequestHeader, getResponseBody, parseRequest,
+        setRequestManager, hAccept)
 import qualified Options.Applicative as OA
 import Options.Applicative ((<|>))
 import Path
@@ -39,7 +36,6 @@ import Stack.Options.DotParser (listDepsOptsParser)
 import System.Process.PagerEditor (pageText)
 import System.Directory (listDirectory)
 import System.IO (stderr, hPutStrLn)
-import Network.HTTP.Client.TLS (getGlobalManager)
 
 data LsView
     = Local

src/Stack/New.hs

@@ -38,7 +38,7 @@ import           Data.Time.Calendar
 import           Data.Time.Clock
 import qualified Data.Yaml as Yaml
 import           Network.HTTP.Download
-import           Network.HTTP.Simple (Request, HttpException, getResponseStatusCode, getResponseBody)
+import           Network.HTTP.StackClient (Request, HttpException, getResponseStatusCode, getResponseBody)
 import           Path
 import           Path.IO
 import           Stack.Constants

src/Stack/PackageIndex.hs

@@ -50,7 +50,7 @@ import qualified Hackage.Security.Client.Repository.Remote as HS
 import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
 import qualified Hackage.Security.Util.Path as HS
 import qualified Hackage.Security.Util.Pretty as HS
-import           Network.HTTP.Client.TLS (getGlobalManager)
+import           Network.HTTP.StackClient (getGlobalManager)
 import           Network.HTTP.Download
 import           Network.URI (parseURI)
 import           Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (</>), parseRelDir)