Specify User-Agent on every HTTP request (commercialhaskell#3628)

Fix: commercialhaskell#3628 Wrap up functions in `Network.HTTP.Client` and `Network.HTTP.Simple` to add User-Agent to the request object.
igrep · Dec 20, 2017 · 416d8f1 · 416d8f1
1 parent 7d68bd6
commit 416d8f1
Show file tree

Hide file tree

Showing 11 changed files with 79 additions and 15 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,