    {-# 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
      env <- IO [(String, String)]
    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 :: 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 a. Maybe a -> Maybe a -> Maybe a
    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 a. a -> IO a
    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
      mstr <- IO (Maybe String)
    proxyString
      case mstr of
        Maybe String
    Nothing     -> Proxy -> IO Proxy
    forall a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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 a. Maybe a -> Maybe a -> Maybe a
    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 = f `fmap` uriAuthority uri }
      where
       f :: URIAuth -> URIAuth
    f a :: URIAuth
    a@URIAuth{uriUserInfo :: URIAuth -> String
    uriUserInfo=String
    s} = URIAuth
    a{uriUserInfo=dropWhileTail (=='@') 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