Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/7a230b03bb557a0dbf0502d9906660aad014ed24 >--------------------------------------------------------------- commit 7a230b03bb557a0dbf0502d9906660aad014ed24 Author: Duncan Coutts <[email protected]> Date: Mon Jun 16 17:03:12 2008 +0000 Try and pick up the http proxy on windows correctly Takes account of the ProxyEnabled reg key Allow proxy uris that lack the http:// uri schema. This should really be moved into the HTTP package. >--------------------------------------------------------------- cabal-install/Hackage/HttpUtils.hs | 80 +++++++++++++++++++++++++++--------- 1 files changed, 60 insertions(+), 20 deletions(-) diff --git a/cabal-install/Hackage/HttpUtils.hs b/cabal-install/Hackage/HttpUtils.hs index 1fd95c5..ed8f02e 100644 --- a/cabal-install/Hackage/HttpUtils.hs +++ b/cabal-install/Hackage/HttpUtils.hs @@ -4,17 +4,29 @@ ----------------------------------------------------------------------------- module Hackage.HttpUtils (getHTTP, proxy) where -import Network.HTTP (Request (..), Response (..), RequestMethod (..), Header(..), HeaderName(..)) -import Network.URI (URI (..), URIAuth (..), parseURI) +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) import Network.Stream (Result) import Network.Browser (Proxy (..), Authority (..), browse, setOutHandler, setErrHandler, setProxy, request) -import Control.Monad (mplus) +import Control.Monad + ( mplus, join ) #ifdef WIN32 -import System.Win32.Registry (hKEY_CURRENT_USER, regOpenKey, regQueryValue, regCloseKey) -import Control.Exception (try, bracket) -#endif +import System.Win32.Types + ( DWORD, HKEY ) +import System.Win32.Registry + ( hKEY_CURRENT_USER, regOpenKey, regCloseKey + , regQueryValue, regQueryValueEx ) +import Control.Exception + ( handle, bracket ) +import Foreign + ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#else import System.Environment (getEnvironment) +#endif import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) @@ -22,13 +34,20 @@ import Distribution.Simple.Utils (warn, debug) import Distribution.Text ( display ) +-- FIXME: all this proxy stuff is far too complicated, especially parsing +-- the proxy strings. Network.Browser should have a way to pick up the +-- proxy settings hiding all this system-dependent stuff below. + -- try to read the system proxy settings on windows or unix proxyString :: IO (Maybe String) #ifdef WIN32 -- read proxy settings from the windows registry -proxyString = fmap (either (const Nothing) Just) $ try $ - bracket (regOpenKey hive path) regCloseKey - (\hkey -> regQueryValue hkey (Just "ProxyServer")) +proxyString = handle (\_ -> return Nothing) $ + bracket (regOpenKey hive path) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing where -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows @@ -37,6 +56,11 @@ proxyString = fmap (either (const Nothing) Just) $ try $ -- end up in the following place: hive = hKEY_CURRENT_USER path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" + + regQueryValueDWORD :: HKEY -> String -> IO DWORD + regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr #else -- read proxy settings by looking for an env var proxyString = do @@ -49,17 +73,33 @@ proxy :: Verbosity -> IO Proxy proxy verbosity = do mstr <- proxyString case mstr of - Nothing -> return NoProxy - Just str -> case parseURI str of - Nothing -> do warn verbosity $ "invalid proxy uri: " ++ show str - warn verbosity $ "ignoring http proxy, trying a direct connection" - return NoProxy - Just uri -> case uri2proxy uri of - Nothing -> do warn verbosity $ "invalid http proxy uri: " ++ show str - warn verbosity $ "proxy uri must be http with a hostname" - warn verbosity $ "ignoring http proxy, trying a direct connection" - return NoProxy - Just p -> return p + Nothing -> return NoProxy + Just str -> case parseHttpProxy str of + Nothing -> do + warn verbosity $ "invalid http proxy uri: " ++ show str + warn verbosity $ "proxy uri must be http with a hostname" + warn verbosity $ "ignoring http proxy, trying a direct connection" + return NoProxy + Just p -> return p + +-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ +-- which lack the @\"http://\"@ URI scheme. The problem is that +-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme +-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. +-- +-- So our strategy is to try parsing as normal uri first and if it lacks the +-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. +-- +parseHttpProxy :: String -> Maybe Proxy +parseHttpProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://"; ++ str) + where + parseHttpURI str' = case parseAbsoluteURI str' of + Just uri@URI { uriAuthority = Just _ } + -> Just uri + _ -> Nothing uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:" _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
