diff --git a/package.yaml b/package.yaml index ebcad27cdf..d0bbbdf3e0 100644 --- a/package.yaml +++ b/package.yaml @@ -143,6 +143,7 @@ library: - Data.Store.VersionTagged - Network.HTTP.Download - Network.HTTP.Download.Verified + - Network.HTTP.StackClient - Options.Applicative.Args - Options.Applicative.Builder.Extra - Options.Applicative.Complicated diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs index 7d95e1be10..dbd33aa88e 100644 --- a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -22,6 +22,7 @@ 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 qualified Network.HTTP.StackClient as StackClient import qualified Network.HTTP.Types as HttpClient import Hackage.Security.Client hiding (Header) @@ -69,7 +70,7 @@ get manager reqHeaders uri callback = wrapCustomEx $ do -- the URI contains URL auth. Not sure if this is a concern. request' <- HttpClient.setUri HttpClient.defaultRequest uri let request = setRequestHeaders reqHeaders request' - checkHttpException $ HttpClient.withResponse request manager $ \response -> do + checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do let br = wrapCustomEx $ HttpClient.responseBody response callback (getResponseHeaders response) br @@ -82,7 +83,7 @@ getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do request' <- HttpClient.setUri HttpClient.defaultRequest uri let request = setRange from to $ setRequestHeaders reqHeaders request' - checkHttpException $ HttpClient.withResponse request manager $ \response -> do + checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do let br = wrapCustomEx $ HttpClient.responseBody response case () of () | HttpClient.responseStatus response == HttpClient.partialContent206 -> diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index 4ea2efeeba..63781b1710 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -15,9 +15,12 @@ module Network.HTTP.Download , download , redownload , httpJSON + , httpLbs + , httpLBS , parseRequest , parseUrlThrow , setGithubHeaders + , withResponse ) where import Stack.Prelude @@ -30,7 +33,8 @@ 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.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode, +import Network.HTTP.StackClient (httpJSON, httpLbs, httpLBS, withResponse) +import Network.HTTP.Simple (getResponseBody, getResponseHeaders, getResponseStatusCode, setRequestHeader) import Path.IO (doesFileExist) import System.Directory (createDirectoryIfMissing, @@ -112,5 +116,4 @@ instance Exception DownloadException -- | Set the user-agent request header setGithubHeaders :: Request -> Request -setGithubHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"] - . setRequestHeader "Accept" ["application/vnd.github.v3+json"] +setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"] diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index 7a08204d6c..cc0b4897ac 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -42,7 +42,8 @@ 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.Simple (Request, HttpException, httpSink, getResponseHeaders) +import Network.HTTP.StackClient (httpSink) +import Network.HTTP.Simple (Request, HttpException, getResponseHeaders) import Network.HTTP.Types.Header (hContentLength, hContentMD5) import Path import Stack.Types.Runner diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs new file mode 100644 index 0000000000..08167a8367 --- /dev/null +++ b/src/Network/HTTP/StackClient.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.StackClient + ( httpJSON + , httpLbs + , httpLBS + , httpNoBody + , httpSink + , setUserAgent + , withResponse + , withResponseByManager + ) where + +import Control.Monad.Catch (MonadMask) +import Data.Aeson (FromJSON) +import qualified Data.ByteString as Strict +import Data.ByteString.Lazy (ByteString) +import Data.Conduit (ConduitM, Sink) +import qualified Network.HTTP.Client +import Network.HTTP.Client (BodyReader, Manager, Request, Response) +import Network.HTTP.Simple (setRequestHeader) +import qualified Network.HTTP.Simple +import UnliftIO (MonadIO) + + +setUserAgent :: Request -> Request +setUserAgent = setRequestHeader "User-Agent" ["The Haskell Stack"] + + +httpJSON :: (MonadIO m, FromJSON a) => Request -> m (Response a) +httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent + + +httpLbs :: MonadIO m => Request -> m (Response ByteString) +httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent + + +httpLBS :: MonadIO m => Request -> m (Response ByteString) +httpLBS = httpLbs + + +httpNoBody :: MonadIO m => Request -> m (Response ()) +httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent + + +httpSink :: (MonadIO m, MonadMask m) => Request -> (Response () -> Sink Strict.ByteString m a) -> m a +httpSink = Network.HTTP.Simple.httpSink . setUserAgent + + +withResponse + :: (MonadIO m, MonadMask m, MonadIO n) + => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a +withResponse = Network.HTTP.Simple.withResponse . setUserAgent + + +withResponseByManager :: Request -> Manager -> (Response BodyReader -> IO a) -> IO a +withResponseByManager = Network.HTTP.Client.withResponse . setUserAgent diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 40b023d0f0..e02eb96d30 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -63,7 +63,8 @@ import Distribution.Version (simplifyVersionRange, mkVersion') import GHC.Conc (getNumProcessors) import Lens.Micro (lens) import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Simple (httpJSON, getResponseBody) +import Network.HTTP.StackClient (httpJSON) +import Network.HTTP.Simple (getResponseBody) import Options.Applicative (Parser, strOption, long, help) import Path import Path.Extra (toFilePathNoTrailingSep) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index 024f0ae06a..f0589a1f8c 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -21,8 +21,9 @@ 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, httpJSON, parseRequest, + (addRequestHeader, getResponseBody, parseRequest, setRequestManager) import Network.HTTP.Types.Header (hAccept) import qualified Options.Applicative as OA diff --git a/src/Stack/New.hs b/src/Stack/New.hs index b8a2ddee89..a13410617b 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -39,7 +39,7 @@ import Data.Time.Calendar import Data.Time.Clock import qualified Data.Yaml as Yaml import Network.HTTP.Download -import Network.HTTP.Simple +import Network.HTTP.Simple (Request, HttpException, getResponseStatusCode, getResponseBody) import Path import Path.IO import Stack.Constants diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 722f6b93fe..544e6fbc32 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -63,7 +63,7 @@ import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) import Distribution.Version (mkVersion') import Lens.Micro (set) -import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode) +import Network.HTTP.Simple (getResponseBody, getResponseStatusCode) import Network.HTTP.Download import Path import Path.CheckInstall (warnInstallSearchPathIssues) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index 35aeb5c327..05e2dbb8ce 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -24,7 +24,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Network.HTTP.Client (RequestBody (RequestBodyBS)) import Network.HTTP.Download -import Network.HTTP.Simple +import Network.HTTP.Simple (setRequestMethod, setRequestBody, getResponseStatusCode) import Network.HTTP.Types (methodPut) import Path import Stack.Package diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index e8fd952414..288d6289b2 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -29,12 +29,11 @@ import qualified Data.Text.IO as TIO import Network.HTTP.Client (Response, RequestBody(RequestBodyLBS), Request) -import Network.HTTP.Simple (withResponse, - getResponseStatusCode, +import Network.HTTP.StackClient (withResponse, httpNoBody) +import Network.HTTP.Simple (getResponseStatusCode, getResponseBody, setRequestHeader, - parseRequest, - httpNoBody) + parseRequest) import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS) import Network.HTTP.Client.TLS (getGlobalManager,