Commit e75d472b authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Update to using HTTP-4000.x

This should fix a long-standing bug with http proxies (ticket #352)
It should also make downloads faster, or at least use less memory.
parent 8b18c0c5
......@@ -14,6 +14,7 @@ import Network.Browser
import Network.HTTP
( Header(..), HeaderName(..)
, Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
import Control.Monad
......@@ -26,7 +27,8 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport)
type BuildReportId = URI
type BuildLog = String
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] -> BrowserAction ()
uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
-> BrowserAction (HandleStream BuildLog) ()
uploadReports uri reports
= forM_ reports $ \(report, mbBuildLog) ->
do buildId <- postBuildReport uri report
......@@ -34,7 +36,8 @@ uploadReports uri reports
Just buildLog -> putBuildLog buildId buildLog
Nothing -> return ()
postBuildReport :: URI -> BuildReport -> BrowserAction BuildReportId
postBuildReport :: URI -> BuildReport
-> BrowserAction (HandleStream BuildLog) BuildReportId
postBuildReport uri buildReport = do
setAllowRedirects False
(_, response) <- request Request {
......@@ -53,7 +56,8 @@ postBuildReport uri buildReport = do
_ -> error "Unrecognised response from server."
where body = BuildReport.show buildReport
putBuildLog :: BuildReportId -> BuildLog -> BrowserAction ()
putBuildLog :: BuildReportId -> BuildLog
-> BrowserAction (HandleStream BuildLog) ()
putBuildLog reportId buildLog = do
--FIXME: do something if the request fails
(_, response) <- request Request {
......
......@@ -36,6 +36,8 @@ import Distribution.Client.IndexUtils as IndexUtils
( getAvailablePackages, disambiguateDependencies )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI)
import Distribution.Client.Utils
( writeFileAtomic )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
......@@ -48,7 +50,7 @@ import Distribution.Simple.Configure
( getInstalledPackages )
import Distribution.Simple.Utils
( die, notice, info, debug, setupMessage
, copyFileVerbose, writeFileAtomic )
, copyFileVerbose )
import Distribution.System
( buildPlatform )
import Distribution.Text
......@@ -68,7 +70,9 @@ import qualified System.FilePath.Posix as FilePath.Posix
import Network.URI
( URI(uriPath, uriScheme) )
import Network.HTTP
( ConnError(..), Response(..) )
( Response(..) )
import Network.Stream
( ConnError(..) )
downloadURI :: Verbosity
......
......@@ -15,6 +15,8 @@ import Network.Browser
, setOutHandler, setErrHandler, setProxy, request)
import Control.Monad
( mplus, join )
import qualified Data.ByteString.Lazy as ByteString
import Data.ByteString.Lazy (ByteString)
#ifdef WIN32
import System.Win32.Types
( DWORD, HKEY )
......@@ -125,15 +127,15 @@ uri2proxy uri@URI{ uriScheme = "http:"
_ -> pwd'
uri2proxy _ = Nothing
mkRequest :: URI -> Request
mkRequest :: URI -> Request ByteString
mkRequest uri = Request{ rqURI = uri
, rqMethod = GET
, rqHeaders = [Header HdrUserAgent userAgent]
, rqBody = "" }
, rqBody = ByteString.empty }
where userAgent = "cabal-install/" ++ display Paths_cabal_install.version
-- |Carry out a GET request, using the local proxy settings
getHTTP :: Verbosity -> URI -> IO (Result Response)
getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))
getHTTP verbosity uri = do
p <- proxy verbosity
let req = mkRequest uri
......
......@@ -21,6 +21,7 @@ import Network.Browser
import Network.HTTP
( Header(..), HeaderName(..), findHeader
, Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
import Network.URI (URI(uriPath), parseURI)
import Data.Char (intToDigit)
......@@ -104,7 +105,8 @@ check verbosity paths = do
notice verbosity $ "Checking " ++ path ++ "... "
handlePackage verbosity checkURI (return ()) path
handlePackage :: Verbosity -> URI -> BrowserAction () -> FilePath -> IO ()
handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()
-> FilePath -> IO ()
handlePackage verbosity uri auth path =
do req <- mkRequest uri path
p <- proxy verbosity
......@@ -126,7 +128,7 @@ handlePackage verbosity uri auth path =
Just "text/plain" -> notice verbosity $ rspBody resp
_ -> debug verbosity $ rspBody resp
mkRequest :: URI -> FilePath -> IO Request
mkRequest :: URI -> FilePath -> IO (Request String)
mkRequest uri path =
do pkg <- readBinaryFile path
boundary <- genBoundary
......
......@@ -71,7 +71,7 @@ Executable cabal
Cabal >= 1.6 && < 1.7,
filepath >= 1.0,
network >= 1 && < 3,
HTTP >= 3000 && < 3002,
HTTP >= 4000.0.2 && < 4001,
zlib >= 0.4 && < 0.6
if flag(old-base)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment