{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------

-- |

-- Module      :  Network.HTTP.Proxy

-- Copyright   :  See LICENSE file

-- License     :  BSD

-- 

-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>

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

{-

#if !defined(WIN32) && defined(mingw32_HOST_OS)

#define WIN32 1

#endif

-}

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

#if defined(WIN32)

import Network.HTTP.Base ( catchIO )

import Control.Monad ( liftM )

import Data.List ( isPrefixOf )

#endif

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 windowsProxyString

windowsProxyString :: IO (Maybe String)

#if !defined(WIN32)

windowsProxyString = return Nothing

#else

windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString

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 :: IO (Maybe String)

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)

-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."

-- even though the following article indicates otherwise

-- https://support.microsoft.com/en-us/kb/819961

--

-- to be sure, parse strings where each entry in the ';'-separated list above is

-- either in the format "protocol=..." or "protocol://..."

--

-- only return the first "http" of them, if it exists

parseWindowsProxy :: String -> Maybe String

parseWindowsProxy s =

  case proxies of

    x:_ -> Just x

    _   -> Nothing

  where

    parts = split ';' s

    pr x = case break (== '=') x of

      (p, []) -> p  -- might be in format http://

      (p, u)  -> p ++ "://" ++ drop 1 u

    proxies = filter (isPrefixOf "http://") . map pr $ parts

    split :: Eq a => a -> [a] -> [[a]]

    split _ [] = []

    split a xs = case break (a ==) xs of

      (ys, [])   -> [ys]

      (ys, _:zs) -> ys:split a zs

#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 "" = Nothing

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