Commit 7ae62bf8 authored by jim's avatar jim
Browse files

Added support for users behind proxy servers, reading system settings from the...

Added support for users behind proxy servers, reading system settings from the env var on unix or registry on windows
parent e4b86e60
......@@ -22,8 +22,7 @@ module Hackage.Fetch
) where
import Network.URI (URI,parseURI,uriScheme,uriPath)
import Network.HTTP (ConnError(..), Request (..), simpleHTTP
, Response(..), RequestMethod (..))
import Network.HTTP (ConnError(..), Response(..))
import Control.Exception (bracket)
import Control.Monad (filterM)
......@@ -33,6 +32,7 @@ import Hackage.Types (ConfigFlags (..), UnresolvedDependency (..), Repo(..), Pkg
import Hackage.Config (repoCacheDir, packageFile, packageDir, pkgURL)
import Hackage.Dependency (resolveDependencies, packagesToInstall)
import Hackage.Utils
import Hackage.HttpUtils (getHTTP)
import Distribution.Package (showPackageId)
import Distribution.Simple.Compiler (Compiler)
......@@ -47,7 +47,7 @@ readURI :: URI -> IO String
readURI uri
| uriScheme uri == "file:" = (readFile $ uriPath uri)
| otherwise = do
eitherResult <- simpleHTTP (Request uri GET [] "")
eitherResult <- getHTTP uri
case eitherResult of
Left err -> die $ "Failed to download '" ++ show uri ++ "': " ++ show err
Right rsp
......@@ -62,17 +62,14 @@ downloadURI path uri
copyFile (uriPath uri) path
return Nothing
| otherwise = do
eitherResult <- simpleHTTP request
eitherResult <- getHTTP uri
case eitherResult of
Left err -> return (Just err)
Right rsp
| rspCode rsp == (2,0,0) -> withBinaryFile path WriteMode (`hPutStr` rspBody rsp)
>> return Nothing
| otherwise -> return (Just (ErrorMisc ("Invalid HTTP code: " ++ show (rspCode rsp))))
where request = Request uri GET [] ""
downloadFile :: FilePath
-> String
-> IO (Maybe ConnError)
......
{-# OPTIONS -cpp #-}
-----------------------------------------------------------------------------
-- | Separate module for HTTP actions, using a proxy server if one exists
-----------------------------------------------------------------------------
module Hackage.HttpUtils (getHTTP, proxy) where
import Network.HTTP (Request (..), Response (..), RequestMethod (..), Header(..), HeaderName(..))
import Network.URI (URI (..), URIAuth (..), parseURI)
import Network.Stream (Result)
import Network.Browser (Proxy (..), Authority (..), browse, setProxy, request)
import Data.Maybe (fromJust)
#ifdef WIN32
import System.Win32.Registry (hKEY_CURRENT_USER, regOpenKey, regQueryValue, regCloseKey)
#else
import System.Posix.Env (getEnv)
#endif
-- try to read the system proxy settings on windows or unix
proxyURI :: IO (Maybe URI)
#ifdef WIN32
-- read proxy settings from the windows registry
proxyURI = do hKey <- return key
uri <- regOpenKey hKey path
>>= flip regQueryValue (Just "ProxyServer")
>>= return . parseURI
regCloseKey hKey
return uri
where {-some sources say proxy settings should be at
HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\ProxyServer
but if the user sets them with IE connection panel they seem to end up in the
following place within HKEY_CURRENT_USER. -}
key = hKEY_CURRENT_USER
path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"
#else
-- read proxy settings by looking for an env var
proxyURI = getEnv "http_proxy" >>= maybe (getEnv "HTTP_PROXY"
>>= parseURIM) (parseURIM . Just)
where parseURIM :: Maybe String -> IO (Maybe URI)
parseURIM = return . maybe Nothing parseURI
#endif
-- |Get the local proxy settings
proxy :: IO Proxy
proxy = proxyURI >>= return . uri2proxy
mkRequest :: URI -> IO Request
mkRequest uri = return Request{ rqURI = uri
, rqMethod = GET
, rqHeaders = [Header HdrUserAgent "Cabal"]
, rqBody = "" }
uri2proxy :: Maybe URI -> Proxy
uri2proxy = maybe NoProxy (\uri ->
let (URIAuth auth' host _) = fromJust $ uriAuthority uri
auth = if null auth' then Nothing
else Just (AuthBasic "" usr pwd uri)
(usr,pwd') = break (==':') auth'
pwd = case pwd' of
':':cs -> cs
_ -> pwd'
in
Proxy host auth)
-- |Carry out a GET request, using the local proxy settings
getHTTP :: URI -> IO (Result Response)
getHTTP uri = do p <- proxy
req <- mkRequest uri
(_, resp) <- browse (setProxy p >> request req)
return (Right resp)
......@@ -5,12 +5,13 @@ module Hackage.Upload (upload) where
import Hackage.Setup (UploadFlags(..))
import Hackage.Types (ConfigFlags(..))
import Hackage.HttpUtils (proxy)
import Distribution.Simple.Utils (debug, notice)
import Distribution.Simple.Setup (toFlag, fromFlag, flagToMaybe)
import Network.Browser (BrowserAction, browse, request,
Authority(..), addAuthority,
setOutHandler, setErrHandler)
setOutHandler, setErrHandler, setProxy)
import Network.HTTP (Header(..), HeaderName(..), Request(..),
RequestMethod(..), Response(..))
import Network.URI (URI, parseURI)
......@@ -49,8 +50,10 @@ handlePackage flags path =
(fromFlag (uploadUsername flags))
(fromFlag (uploadPassword flags)))
req <- mkRequest uri path
p <- proxy
debug verbosity $ "\n" ++ show req
(_,resp) <- browse (setErrHandler ignoreMsg
(_,resp) <- browse (setProxy p
>> setErrHandler ignoreMsg
>> setOutHandler ignoreMsg
>> auth
>> request req)
......
......@@ -37,6 +37,7 @@ Executable cabal
Hackage.Config
Hackage.Dependency
Hackage.Fetch
Hackage.HttpUtils
Hackage.Index
Hackage.Info
Hackage.Install
......@@ -61,3 +62,9 @@ Executable cabal
build-depends: base >= 2.0 && < 2.2
else
build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9
if os(windows)
build-depends: Win32 >= 2
cpp-options: -DWIN32
else
build-depends: unix >= 1
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