Merge pull request #3682 from igrep/user-agent

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

Author: mgsloan

ChangeLog.md

@@ -13,6 +13,8 @@ Other enhancements:
 * A new sub command `ls` has been introduced to stack to view
   local and remote snapshots present in the system. Use `stack ls
   snapshots --help` to get more details about it.
+* Specify User-Agent HTTP request header on every HTTP request.
+  See [#3628](https://github.com/commercialhaskell/stack/issues/3628) for details.
 
 * In addition to supporting `.tar.gz` and `.zip` files as remote archives,
   plain `.tar` files are now accepted too. This will additionally help with

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

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 ->

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"]

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

src/Network/HTTP/StackClient.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- Wrapper functions of 'Network.HTTP.Simple' and 'Network.HTTP.Client' to
+-- add the 'User-Agent' HTTP request header to each request.
+
+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

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)

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

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

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)