{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts  #-}

{-
Copyright (c) 2002, Warrick Gray
Copyright (c) 2002-2005, Ian Lynagh
Copyright (c) 2003-2006, Bjorn Bringert
Copyright (c) 2004, Andre Furtado
Copyright (c) 2004-2005, Dominic Steinitz
Copyright (c) 2007, Robin Bate Boerop
Copyright (c) 2008-2010, Sigbjorn Finne
Copyright (c) 2009, Eric Kow
Copyright (c) 2010, Antoine Latter
Copyright (c) 2004, 2010-2011, Ganesh Sittampalam
Copyright (c) 2011, Duncan Coutts
Copyright (c) 2011, Matthew Gruen
Copyright (c) 2011, Jeremy Yallop
Copyright (c) 2011, Eric Hesselink
Copyright (c) 2011, Yi Huang
Copyright (c) 2011, Tom Lokhorst
Copyright (c) 2017, Vassil Keremidchiev

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * The names of contributors may not be used to endorse or promote
      products derived from this software without specific prior
      written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}

module Network.HTTP.Proxy(  ProxyProtocol(..), EnvHelper(..),
                            systemProxyHelper, envHelper,
                            httpProtocol,
                            ProxySettings ) where

import qualified Control.Applicative         as A
import           Control.Arrow               (first)
import           Control.Monad               (guard)
import qualified Data.ByteString.Char8       as S8
import           Data.Char                   (toLower)
import qualified Data.Map                    as Map
import qualified Data.Text                   as T
import           Data.Text.Read              (decimal)
import           Network.HTTP.Client.Request (applyBasicProxyAuth,
                                              extractBasicAuthInfo)
import           Network.HTTP.Client.Types   (HttpExceptionContent (..),
                                              Proxy (..), Request (..),
                                              throwHttp)
import qualified Network.URI                 as U
import           System.Environment          (getEnvironment)

#if defined(mingw32_HOST_OS)
import           Control.Exception           (IOException, bracket, catch, try)
import           Control.Monad               (join, liftM, mplus, when)
import           Data.List                   (isInfixOf, isPrefixOf)
import           Foreign                     (Storable (peek, sizeOf), alloca,
                                              castPtr, toBool)
import           Network.URI                 (parseAbsoluteURI)
import           Safe                        (readDef)
import           System.IO
import           System.Win32.Registry       (hKEY_CURRENT_USER, rEG_DWORD,
                                              regCloseKey, regOpenKey,
                                              regQueryValue, regQueryValueEx)
import           System.Win32.Types          (DWORD, HKEY)
#endif

type EnvName     = T.Text
type HostAddress = S8.ByteString
type UserName    = S8.ByteString
type Password    = S8.ByteString

-- There are other proxy protocols like SOCKS, FTP, etc.
data ProxyProtocol = HTTPProxy | HTTPSProxy

instance Show ProxyProtocol where
    show :: ProxyProtocol -> String
show ProxyProtocol
HTTPProxy  = String
"http"
    show ProxyProtocol
HTTPSProxy = String
"https"

data ProxySettings = ProxySettings { ProxySettings -> Proxy
_proxyHost :: Proxy,
                                     ProxySettings -> Maybe (UserName, UserName)
_proxyAuth :: Maybe (UserName, Password) }
                                     deriving Int -> ProxySettings -> ShowS
[ProxySettings] -> ShowS
ProxySettings -> String
(Int -> ProxySettings -> ShowS)
-> (ProxySettings -> String)
-> ([ProxySettings] -> ShowS)
-> Show ProxySettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProxySettings] -> ShowS
$cshowList :: [ProxySettings] -> ShowS
show :: ProxySettings -> String
$cshow :: ProxySettings -> String
showsPrec :: Int -> ProxySettings -> ShowS
$cshowsPrec :: Int -> ProxySettings -> ShowS
Show

httpProtocol :: Bool -> ProxyProtocol
httpProtocol :: Bool -> ProxyProtocol
httpProtocol Bool
True  = ProxyProtocol
HTTPSProxy
httpProtocol Bool
False = ProxyProtocol
HTTPProxy

data EnvHelper = EHFromRequest
               | EHNoProxy
               | EHUseProxy Proxy

headJust :: [Maybe a] -> Maybe a
headJust :: [Maybe a] -> Maybe a
headJust []               = Maybe a
forall a. Maybe a
Nothing
headJust (Maybe a
Nothing:[Maybe a]
xs)     = [Maybe a] -> Maybe a
forall a. [Maybe a] -> Maybe a
headJust [Maybe a]
xs
headJust ((y :: Maybe a
y@(Just a
_)):[Maybe a]
_) = Maybe a
y

systemProxyHelper :: Maybe T.Text -> ProxyProtocol -> EnvHelper -> IO (Request -> Request)
systemProxyHelper :: Maybe Text -> ProxyProtocol -> EnvHelper -> IO (Request -> Request)
systemProxyHelper Maybe Text
envOveride ProxyProtocol
prot EnvHelper
eh = do
    let envName' :: Maybe Text -> Text
envName' Maybe Text
Nothing     = ProxyProtocol -> Text
envName ProxyProtocol
prot
        envName' (Just Text
name) = Text
name

    UserName -> Maybe ProxySettings
modifier <- Text -> IO (UserName -> Maybe ProxySettings)
envHelper (Maybe Text -> Text
envName' Maybe Text
envOveride)

-- Under Windows try first env. variables override then Windows proxy settings
#if defined(mingw32_HOST_OS)
    modifier' <- systemProxy prot
    let modifiers = [modifier, modifier']
#else
    let modifiers :: [UserName -> Maybe ProxySettings]
modifiers = [UserName -> Maybe ProxySettings
modifier]
#endif

    let chooseMod :: Request -> Maybe ProxySettings
        chooseMod :: Request -> Maybe ProxySettings
chooseMod Request
req = [Maybe ProxySettings] -> Maybe ProxySettings
forall a. [Maybe a] -> Maybe a
headJust ([Maybe ProxySettings] -> Maybe ProxySettings)
-> ([UserName -> Maybe ProxySettings] -> [Maybe ProxySettings])
-> [UserName -> Maybe ProxySettings]
-> Maybe ProxySettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserName -> Maybe ProxySettings) -> Maybe ProxySettings)
-> [UserName -> Maybe ProxySettings] -> [Maybe ProxySettings]
forall a b. (a -> b) -> [a] -> [b]
map (\UserName -> Maybe ProxySettings
m -> UserName -> Maybe ProxySettings
m (UserName -> Maybe ProxySettings)
-> (Request -> UserName) -> Request -> Maybe ProxySettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> UserName
host (Request -> Maybe ProxySettings) -> Request -> Maybe ProxySettings
forall a b. (a -> b) -> a -> b
$ Request
req) ([UserName -> Maybe ProxySettings] -> Maybe ProxySettings)
-> [UserName -> Maybe ProxySettings] -> Maybe ProxySettings
forall a b. (a -> b) -> a -> b
$ [UserName -> Maybe ProxySettings]
modifiers

        noEnvProxy :: Request -> Request
noEnvProxy = case EnvHelper
eh of
            EnvHelper
EHFromRequest -> Request -> Request
forall a. a -> a
id
            EnvHelper
EHNoProxy     -> \Request
req -> Request
req { proxy :: Maybe Proxy
proxy = Maybe Proxy
forall a. Maybe a
Nothing }
            EHUseProxy Proxy
p  -> \Request
req -> Request
req { proxy :: Maybe Proxy
proxy = Proxy -> Maybe Proxy
forall a. a -> Maybe a
Just Proxy
p  }

    let result :: Request -> Request
result Request
req = Maybe ProxySettings -> Request
toRequest (Maybe ProxySettings -> Request)
-> (Request -> Maybe ProxySettings) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ProxySettings
chooseMod (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
req where
            toRequest :: Maybe ProxySettings -> Request
toRequest Maybe ProxySettings
Nothing                            = Request -> Request
noEnvProxy Request
req
            toRequest (Just (ProxySettings Proxy
p Maybe (UserName, UserName)
muserpass)) = (Request -> Request)
-> ((UserName, UserName) -> Request -> Request)
-> Maybe (UserName, UserName)
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id ((UserName -> UserName -> Request -> Request)
-> (UserName, UserName) -> Request -> Request
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UserName -> UserName -> Request -> Request
applyBasicProxyAuth) Maybe (UserName, UserName)
muserpass
                                        Request
req { proxy :: Maybe Proxy
proxy = Proxy -> Maybe Proxy
forall a. a -> Maybe a
Just Proxy
p }
    (Request -> Request) -> IO (Request -> Request)
forall (m :: * -> *) a. Monad m => a -> m a
return Request -> Request
result


#if defined(mingw32_HOST_OS)
windowsProxyString :: ProxyProtocol -> IO (Maybe (String, String))
windowsProxyString proto = do
    mProxy <- registryProxyString
    return $ do
        (proxies, exceptions) <- mProxy
        protoProxy <- parseWindowsProxy proto proxies
        return (protoProxy, exceptions)

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, String))
registryProxyString = catch
  (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do
    enable <- toBool . maybe 0 id A.<$> regQueryValueDWORD hkey "ProxyEnable"
    if enable
        then do
#if MIN_VERSION_Win32(2, 6, 0) && !MIN_VERSION_Win32(2, 8, 0)
            server <- regQueryValue hkey "ProxyServer"
            exceptions <- try $ regQueryValue hkey "ProxyOverride" :: IO (Either IOException String)
#else
            server <- regQueryValue hkey (Just "ProxyServer")
            exceptions <- try $ regQueryValue hkey (Just "ProxyOverride") :: IO (Either IOException String)
#endif
            return $ Just (server, either (const "") id exceptions)
        else return Nothing)
  hideError where
      hideError :: IOException -> IO (Maybe (String, String))
      hideError _ = 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://..."
parseWindowsProxy :: ProxyProtocol -> String -> Maybe String
parseWindowsProxy proto 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

    protoPrefix = (show proto) ++ "://"
    proxies = filter (isPrefixOf protoPrefix) . 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

-- Extract proxy settings from Windows registry. This is a standard way in Windows OS.
systemProxy :: ProxyProtocol -> IO (HostAddress -> Maybe ProxySettings)
systemProxy proto = do
    let isURLlocal "127.0.0.1" = True
        isURLlocal "localhost" = True
        isURLlocal _           = False

        hasLocal exceptions = "<local>" `isInfixOf` exceptions

    settings <- fetchProxy proto
    return $ \url -> do
        (proxy, exceptions) <- settings

        -- Skip proxy for local hosts if it's enabled in IE settings
        -- TODO Implement skipping for address patterns, like (*.google.com)
        if (isURLlocal url && hasLocal exceptions) || (url `S8.isInfixOf` (S8.pack exceptions)) then Nothing
        else Just proxy

-- | @fetchProxy flg@ gets the local proxy settings and parse the string
-- into a @Proxy@ value.
-- Proxy settings are sourced from IE/WinInet's proxy
-- setting in the Registry.
fetchProxy :: ProxyProtocol -> IO (Maybe (ProxySettings, String))
fetchProxy proto = do
    mstr <- windowsProxyString proto
    case mstr of
      Nothing               -> return Nothing
      Just (proxy, except)  -> case parseProxy proto proxy of
          Just p  -> return $ Just (p, except)
          Nothing ->
              throwHttp . InvalidProxySettings . T.pack . unlines $
                      [ "Invalid http proxy uri: " ++ show proxy
                      , "proxy uri must be http with a hostname"
                      , "ignoring http proxy, trying a direct connection"
                      ]

-- | @parseProxy str@ translates a proxy server string into a @ProxySettings@ value;
-- returns @Nothing@ if not well-formed.
parseProxy :: ProxyProtocol -> String -> Maybe ProxySettings
parseProxy proto str = join
                 . fmap (uri2proxy proto)
                 $ parseHttpURI str
                 `mplus` parseHttpURI (protoPrefix ++ str)
    where
     protoPrefix = (show proto) ++ "://"
     parseHttpURI str' =
      case parseAbsoluteURI str' of
        Just uri@U.URI{U.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.
       --

-- | @dropWhileTail p ls@ chops off trailing elements from @ls@
-- until @p@ returns @False@.
dropWhileTail :: (a -> Bool) -> [a] -> [a]
dropWhileTail f ls =
    case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] }
     where
       chop x (Just xs) = Just (x:xs)
       chop x _
        | f x       = Nothing
        | otherwise = Just [x]

-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence
-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second
-- list is empty and the first is equal to @ls@.
chopAtDelim :: Eq a => a -> [a] -> ([a],[a])
chopAtDelim elt xs =
    case break (==elt) xs of
    (_,[])    -> (xs,[])
    (as,_:bs) -> (as,bs)

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

defaultHTTPport :: ProxyProtocol -> Int
defaultHTTPport HTTPProxy  = 80
defaultHTTPport HTTPSProxy = 443

uri2proxy :: ProxyProtocol -> U.URI -> Maybe ProxySettings
uri2proxy proto uri@U.URI{ U.uriAuthority = Just (U.URIAuth auth' hst prt) } =
    if (show proto ++ ":") == U.uriScheme uri then
        Just (ProxySettings (Proxy (S8.pack hst) (port prt)) auth) else Nothing
    where
     port (':':xs) = readDef (defaultHTTPport proto) xs
     port _        = (defaultHTTPport proto)

     auth =
       case auth' of
         [] -> Nothing
         as -> Just ((S8.pack . U.unEscapeString $ usr), (S8.pack . U.unEscapeString $ pwd))
          where
           (usr,pwd) = chopAtDelim ':' as

uri2proxy _ _ = Nothing

regQueryValueDWORD :: HKEY -> String -> IO (Maybe DWORD)
regQueryValueDWORD hkey name = alloca $ \ptr -> do
  key <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))
  if key == rEG_DWORD then
      Just A.<$> peek ptr
  else return Nothing

-- defined(mingw32_HOST_OS)
#endif

envName :: ProxyProtocol -> EnvName
envName :: ProxyProtocol -> Text
envName ProxyProtocol
proto = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ProxyProtocol -> String
forall a. Show a => a -> String
show ProxyProtocol
proto String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_proxy"

-- Extract proxy settings from environment variables. This is a standard way in Linux.
envHelper :: EnvName -> IO (HostAddress -> Maybe ProxySettings)
envHelper :: Text -> IO (UserName -> Maybe ProxySettings)
envHelper Text
name = do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  let lenv :: Map Text String
lenv = [(Text, String)] -> Map Text String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, String)] -> Map Text String)
-> [(Text, String)] -> Map Text String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (Text, String))
-> [(String, String)] -> [(Text, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text) -> (String, String) -> (Text, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String -> Text) -> (String, String) -> (Text, String))
-> (String -> Text) -> (String, String) -> (Text, String)
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [(String, String)]
env
      lookupEnvVar :: Text -> Maybe String
lookupEnvVar Text
n = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> String
T.unpack Text
n) [(String, String)]
env Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
A.<|> Text -> Map Text String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n Map Text String
lenv
      noProxyDomains :: [UserName]
noProxyDomains = Maybe String -> [UserName]
domainSuffixes (Text -> Maybe String
lookupEnvVar Text
"no_proxy")

  case Text -> Maybe String
lookupEnvVar Text
name of
      Maybe String
Nothing  -> (UserName -> Maybe ProxySettings)
-> IO (UserName -> Maybe ProxySettings)
forall (m :: * -> *) a. Monad m => a -> m a
return ((UserName -> Maybe ProxySettings)
 -> IO (UserName -> Maybe ProxySettings))
-> (Maybe ProxySettings -> UserName -> Maybe ProxySettings)
-> Maybe ProxySettings
-> IO (UserName -> Maybe ProxySettings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ProxySettings -> UserName -> Maybe ProxySettings
forall a b. a -> b -> a
const (Maybe ProxySettings -> IO (UserName -> Maybe ProxySettings))
-> Maybe ProxySettings -> IO (UserName -> Maybe ProxySettings)
forall a b. (a -> b) -> a -> b
$ Maybe ProxySettings
forall a. Maybe a
Nothing
      Just String
""  -> (UserName -> Maybe ProxySettings)
-> IO (UserName -> Maybe ProxySettings)
forall (m :: * -> *) a. Monad m => a -> m a
return ((UserName -> Maybe ProxySettings)
 -> IO (UserName -> Maybe ProxySettings))
-> (Maybe ProxySettings -> UserName -> Maybe ProxySettings)
-> Maybe ProxySettings
-> IO (UserName -> Maybe ProxySettings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ProxySettings -> UserName -> Maybe ProxySettings
forall a b. a -> b -> a
const (Maybe ProxySettings -> IO (UserName -> Maybe ProxySettings))
-> Maybe ProxySettings -> IO (UserName -> Maybe ProxySettings)
forall a b. (a -> b) -> a -> b
$ Maybe ProxySettings
forall a. Maybe a
Nothing
      Just String
str -> do
          let invalid :: IO a
invalid = HttpExceptionContent -> IO a
forall a. HttpExceptionContent -> IO a
throwHttp (HttpExceptionContent -> IO a) -> HttpExceptionContent -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> HttpExceptionContent
InvalidProxyEnvironmentVariable Text
name (String -> Text
T.pack String
str)
          (Proxy
p, Maybe (UserName, UserName)
muserpass) <- IO (Proxy, Maybe (UserName, UserName))
-> ((Proxy, Maybe (UserName, UserName))
    -> IO (Proxy, Maybe (UserName, UserName)))
-> Maybe (Proxy, Maybe (UserName, UserName))
-> IO (Proxy, Maybe (UserName, UserName))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (Proxy, Maybe (UserName, UserName))
forall a. IO a
invalid (Proxy, Maybe (UserName, UserName))
-> IO (Proxy, Maybe (UserName, UserName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Proxy, Maybe (UserName, UserName))
 -> IO (Proxy, Maybe (UserName, UserName)))
-> Maybe (Proxy, Maybe (UserName, UserName))
-> IO (Proxy, Maybe (UserName, UserName))
forall a b. (a -> b) -> a -> b
$ do
              let allowedScheme :: a -> Bool
allowedScheme a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"http:"
              URI
uri <- case String -> Maybe URI
U.parseURI String
str of
                  Just URI
u | String -> Bool
forall a. (Eq a, IsString a) => a -> Bool
allowedScheme (URI -> String
U.uriScheme URI
u) -> URI -> Maybe URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
u
                  Maybe URI
_      -> String -> Maybe URI
U.parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. (Eq a, IsString a) => a -> Bool
allowedScheme (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriScheme URI
uri
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
U.uriPath URI
uri) Bool -> Bool -> Bool
|| URI -> String
U.uriPath URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"/"
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriQuery URI
uri
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriFragment URI
uri

              URIAuth
auth <- URI -> Maybe URIAuth
U.uriAuthority URI
uri
              Int
port' <-
                  case URIAuth -> String
U.uriPort URIAuth
auth of
                      String
"" -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
80
                      Char
':':String
rest ->
                          case Reader Int
forall a. Integral a => Reader a
decimal Reader Int -> Reader Int
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
rest of
                              Right (Int
p, Text
"") -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
p
                              Either String (Int, Text)
_             -> Maybe Int
forall a. Maybe a
Nothing
                      String
_ -> Maybe Int
forall a. Maybe a
Nothing

              (Proxy, Maybe (UserName, UserName))
-> Maybe (Proxy, Maybe (UserName, UserName))
forall a. a -> Maybe a
Just (UserName -> Int -> Proxy
Proxy (String -> UserName
S8.pack (String -> UserName) -> String -> UserName
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
U.uriRegName URIAuth
auth) Int
port', URI -> Maybe (UserName, UserName)
extractBasicAuthInfo URI
uri)
          (UserName -> Maybe ProxySettings)
-> IO (UserName -> Maybe ProxySettings)
forall (m :: * -> *) a. Monad m => a -> m a
return ((UserName -> Maybe ProxySettings)
 -> IO (UserName -> Maybe ProxySettings))
-> (UserName -> Maybe ProxySettings)
-> IO (UserName -> Maybe ProxySettings)
forall a b. (a -> b) -> a -> b
$ \UserName
hostRequest ->
              if UserName
hostRequest UserName -> [UserName] -> Bool
forall (t :: * -> *). Foldable t => UserName -> t UserName -> Bool
`hasDomainSuffixIn` [UserName]
noProxyDomains
              then Maybe ProxySettings
forall a. Maybe a
Nothing
              else ProxySettings -> Maybe ProxySettings
forall a. a -> Maybe a
Just (ProxySettings -> Maybe ProxySettings)
-> ProxySettings -> Maybe ProxySettings
forall a b. (a -> b) -> a -> b
$ Proxy -> Maybe (UserName, UserName) -> ProxySettings
ProxySettings Proxy
p Maybe (UserName, UserName)
muserpass
  where prefixed :: UserName -> UserName
prefixed UserName
s | UserName -> Char
S8.head UserName
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' = UserName
s
                   | Bool
otherwise = Char -> UserName -> UserName
S8.cons Char
'.' UserName
s
        domainSuffixes :: Maybe String -> [UserName]
domainSuffixes Maybe String
Nothing = []
        domainSuffixes (Just String
"") = []
        domainSuffixes (Just String
no_proxy) = [UserName -> UserName
prefixed (UserName -> UserName) -> UserName -> UserName
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> UserName -> UserName
S8.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') UserName
suffix | UserName
suffix <- Char -> UserName -> [UserName]
S8.split Char
',' (String -> UserName
S8.pack ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
no_proxy)), Bool -> Bool
not (UserName -> Bool
S8.null UserName
suffix)]
        hasDomainSuffixIn :: UserName -> t UserName -> Bool
hasDomainSuffixIn UserName
host' = (UserName -> Bool) -> t UserName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UserName -> UserName -> Bool
`S8.isSuffixOf` UserName -> UserName
prefixed ((Char -> Char) -> UserName -> UserName
S8.map Char -> Char
toLower UserName
host'))