{-# 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, regQueryValueEx )
import Control.Exception    ( bracket )
import Foreign              ( toBool, Storable(peek, sizeOf), castPtr, alloca )

#if MIN_VERSION_Win32(2,8,0)
import System.Win32.Registry( regQueryDefaultValue )
#else
import System.Win32.Registry( regQueryValue )
#endif
#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 :: Proxy
noProxy = Proxy
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 :: IO (Maybe String)
envProxyString = do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"http_proxy" [(String, String)]
env Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"HTTP_PROXY" [(String, String)]
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 :: IO (Maybe String)
proxyString = (Maybe String -> Maybe String -> Maybe String)
-> IO (Maybe String) -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus IO (Maybe String)
envProxyString IO (Maybe String)
windowsProxyString

windowsProxyString :: IO (Maybe String)
#if !defined(WIN32)
windowsProxyString :: IO (Maybe String)
windowsProxyString = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
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
#if MIN_VERSION_Win32(2,8,0)
        then fmap Just $ regQueryDefaultValue hkey "ProxyServer"
#elif MIN_VERSION_Win32(2,6,0)
        then fmap Just $ regQueryValue hkey "ProxyServer"
#else
        then fmap Just $ regQueryValue hkey (Just "ProxyServer")
#endif
        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 :: Bool -> IO Proxy
fetchProxy Bool
warnIfIllformed = do
  Maybe String
mstr <- IO (Maybe String)
proxyString
  case Maybe String
mstr of
    Maybe String
Nothing     -> Proxy -> IO Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
NoProxy
    Just String
str    -> case String -> Maybe Proxy
parseProxy String
str of
        Just Proxy
p  -> Proxy -> IO Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
p
        Maybe Proxy
Nothing -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
warnIfIllformed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
System.IO.hPutStrLn Handle
System.IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                    [ String
"invalid http proxy uri: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str
                    , String
"proxy uri must be http with a hostname"
                    , String
"ignoring http proxy, trying a direct connection"
                    ]
            Proxy -> IO Proxy
forall (m :: * -> *) a. Monad m => a -> m a
return Proxy
NoProxy

-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value;
-- returns @Nothing@ if not well-formed.
parseProxy :: String -> Maybe Proxy
parseProxy :: String -> Maybe Proxy
parseProxy String
"" = Maybe Proxy
forall a. Maybe a
Nothing
parseProxy String
str = Maybe (Maybe Proxy) -> Maybe Proxy
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
                   (Maybe (Maybe Proxy) -> Maybe Proxy)
-> (Maybe URI -> Maybe (Maybe Proxy)) -> Maybe URI -> Maybe Proxy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (URI -> Maybe Proxy) -> Maybe URI -> Maybe (Maybe Proxy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> Maybe Proxy
uri2proxy
                   (Maybe URI -> Maybe Proxy) -> Maybe URI -> Maybe Proxy
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseHttpURI String
str
             Maybe URI -> Maybe URI -> Maybe URI
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe URI
parseHttpURI (String
"http://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)
  where
   parseHttpURI :: String -> Maybe URI
parseHttpURI String
str' =
    case String -> Maybe URI
parseAbsoluteURI String
str' of
      Just uri :: URI
uri@URI{uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just{}} -> URI -> Maybe URI
forall a. a -> Maybe a
Just (URI -> URI
fixUserInfo URI
uri)
      Maybe URI
_  -> Maybe URI
forall a. Maybe a
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
fixUserInfo URI
uri = URI
uri{ uriAuthority :: Maybe URIAuth
uriAuthority = URIAuth -> URIAuth
f (URIAuth -> URIAuth) -> Maybe URIAuth -> Maybe URIAuth
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` URI -> Maybe URIAuth
uriAuthority URI
uri }
  where
   f :: URIAuth -> URIAuth
f a :: URIAuth
a@URIAuth{uriUserInfo :: URIAuth -> String
uriUserInfo=String
s} = URIAuth
a{uriUserInfo :: String
uriUserInfo=(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileTail (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'@') String
s}

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

uri2proxy URI
_ = Maybe Proxy
forall a. Maybe a
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