work around default Accept-Encoding in http-client
This commit is contained in:
parent
e0227dfedf
commit
6ab0737a75
1 changed files with 15 additions and 1 deletions
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Utility.Url (
|
module Utility.Url (
|
||||||
URLString,
|
URLString,
|
||||||
|
@ -26,6 +27,7 @@ import Network.HTTP.Conduit
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.UTF8 as B8
|
import qualified Data.ByteString.UTF8 as B8
|
||||||
|
|
||||||
import qualified Build.SysConfig
|
import qualified Build.SysConfig
|
||||||
|
@ -130,7 +132,7 @@ exists url uo = case parseURIRelaxed url of
|
||||||
(responseHeaders resp)
|
(responseHeaders resp)
|
||||||
|
|
||||||
existsconduit req = withManager $ \mgr -> do
|
existsconduit req = withManager $ \mgr -> do
|
||||||
let req' = (applyRequest uo req) { method = methodHead }
|
let req' = headRequest (applyRequest uo req)
|
||||||
resp <- http req' mgr
|
resp <- http req' mgr
|
||||||
-- forces processing the response before the
|
-- forces processing the response before the
|
||||||
-- manager is closed
|
-- manager is closed
|
||||||
|
@ -140,6 +142,18 @@ exists url uo = case parseURIRelaxed url of
|
||||||
liftIO $ closeManager mgr
|
liftIO $ closeManager mgr
|
||||||
return ret
|
return ret
|
||||||
|
|
||||||
|
headRequest :: Request -> Request
|
||||||
|
headRequest r = r
|
||||||
|
{ method = methodHead
|
||||||
|
-- remove defaut Accept-Encoding header, to get actual,
|
||||||
|
-- not gzip compressed size.
|
||||||
|
, requestHeaders = (hAcceptEncoding, B.empty) :
|
||||||
|
filter (\(h, _) -> h /= hAcceptEncoding)
|
||||||
|
(requestHeaders r)
|
||||||
|
}
|
||||||
|
where
|
||||||
|
hAcceptEncoding = "Accept-Encoding"
|
||||||
|
|
||||||
{- Used to download large files, such as the contents of keys.
|
{- Used to download large files, such as the contents of keys.
|
||||||
-
|
-
|
||||||
- Uses wget or curl program for its progress bar. (Wget has a better one,
|
- Uses wget or curl program for its progress bar. (Wget has a better one,
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue