{-# 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