[commit: Cabal] master: Try and pick up the http proxy on windows correctly (7a230b0)

[Ian Lynagh]

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 <duncan at haskell.org>
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 at URI { uriAuthority = Just _ }
+         -> Just uri
+      _  -> Nothing
 
 uri2proxy :: URI -> Maybe Proxy
 uri2proxy uri at URI{ uriScheme = "http:"