Network/HTTP/Proxy.hs

{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Proxy
-- Copyright : See LICENSE file
-- License : BSD
-- 
-- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- Handling proxy server settings and their resolution.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.Proxy
 ( Proxy(..)
 , noProxy -- :: Proxy
 , fetchProxy -- :: Bool -> IO Proxy
 , parseProxy -- :: String -> Maybe Proxy
 ) where

import Control.Monad ( when, mplus, join, liftM2)

import Network.HTTP.Base ( catchIO )
import Network.HTTP.Utils ( dropWhileTail, chopAtDelim )
import Network.HTTP.Auth
import Network.URI
 ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString )
import System.IO ( hPutStrLn, stderr )
import System.Environment

{-
#if !defined(WIN32) && defined(mingw32_HOST_OS)
#define WIN32 1
#endif
-}

#if defined(WIN32)
import System.Win32.Types ( DWORD, HKEY )
import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx )
import Control.Exception ( bracket )
import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca )
#endif

-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a
-- proxy should be used for the request (see 'Network.Browser.setProxy')
data Proxy 
 = NoProxy -- ^ Don't use a proxy.
 | Proxy String
 (Maybe Authority) -- ^ Use the proxy given. Should be of the
 -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host".
 -- Additionally, an optional 'Authority' for authentication with the proxy.


noProxy :: Proxy
noProxy = NoProxy

-- | @envProxyString@ locates proxy server settings by looking
-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.)
-- If no mapping found, returns @Nothing@.
envProxyString :: IO (Maybe String)
envProxyString = do
 env <- getEnvironment
 return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)

-- | @proxyString@ tries to locate the user's proxy server setting.
-- Consults environment variable, and in case of Windows, by querying
-- the Registry (cf. @registryProxyString@.)
proxyString :: IO (Maybe String)
proxyString = liftM2 mplus envProxyString registryProxyString

registryProxyString :: IO (Maybe String)
#if !defined(WIN32)
registryProxyString = return Nothing
#else
registryProxyLoc :: (HKEY,String)
registryProxyLoc = (hive, path)
 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:
 hive = hKEY_CURRENT_USER
 path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"

-- read proxy settings from the windows registry; this is just a best
-- effort and may not work on all setups. 
registryProxyString = catchIO
 (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do
 enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"
 if enable
 then fmap Just $ regQueryValue hkey (Just "ProxyServer")
 else return Nothing)
 (\_ -> return Nothing)
#endif

-- | @fetchProxy flg@ gets the local proxy settings and parse the string
-- into a @Proxy@ value. If you want to be informed of ill-formed proxy
-- configuration strings, supply @True@ for @flg@.
-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable,
-- and in the case of Windows platforms, by consulting IE/WinInet's proxy
-- setting in the Registry.
fetchProxy :: Bool -> IO Proxy
fetchProxy warnIfIllformed = do
 mstr <- proxyString
 case mstr of
 Nothing -> return NoProxy
 Just str -> case parseProxy str of
 Just p -> return p 
 Nothing -> do
 when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines
 [ "invalid http proxy uri: " ++ show str
 , "proxy uri must be http with a hostname"
 , "ignoring http proxy, trying a direct connection"
 ]
 return NoProxy

-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value;
-- returns @Nothing@ if not well-formed.
parseProxy :: String -> Maybe Proxy
parseProxy str = join
 . fmap uri2proxy
 $ parseHttpURI str
 `mplus` parseHttpURI ("http://" ++ str)
 where
 parseHttpURI str' =
 case parseAbsoluteURI str' of
 Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri)
 _ -> Nothing

 -- Note: 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.
 --

-- | tidy up user portion, don't want the trailing "\@".
fixUserInfo :: URI -> URI
fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }
 where
 f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s}

-- 
uri2proxy :: URI -> Maybe Proxy
uri2proxy uri@URI{ uriScheme = "http:"
 , uriAuthority = Just (URIAuth auth' hst prt)
 } =
 Just (Proxy (hst ++ prt) auth)
 where
 auth =
 case auth' of
 [] -> Nothing
 as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri)
 where
	 (usr,pwd) = chopAtDelim ':' as

uri2proxy _ = Nothing

-- utilities
#if defined(WIN32)
regQueryValueDWORD :: HKEY -> String -> IO DWORD
regQueryValueDWORD hkey name = alloca $ \ptr -> do
 -- TODO: this throws away the key type returned by regQueryValueEx
 -- we should check it's what we expect instead
 _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))
 peek ptr

#endif