{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
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
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
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 :: forall a. [Maybe a] -> Maybe a
headJust [] = forall a. Maybe a
Nothing
headJust (Maybe a
Nothing:[Maybe a]
xs) = 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)
#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 = forall a. [Maybe a] -> Maybe a
headJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\UserName -> Maybe ProxySettings
m -> UserName -> Maybe ProxySettings
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> UserName
host forall a b. (a -> b) -> a -> b
$ Request
req) forall a b. (a -> b) -> a -> b
$ [UserName -> Maybe ProxySettings]
modifiers
noEnvProxy :: Request -> Request
noEnvProxy = case EnvHelper
eh of
EnvHelper
EHFromRequest -> forall a. a -> a
id
EnvHelper
EHNoProxy -> \Request
req -> Request
req { proxy :: Maybe Proxy
proxy = forall a. Maybe a
Nothing }
EHUseProxy Proxy
p -> \Request
req -> Request
req { proxy :: Maybe Proxy
proxy = forall a. a -> Maybe a
Just Proxy
p }
let result :: Request -> Request
result Request
req = Maybe ProxySettings -> Request
toRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Maybe ProxySettings
chooseMod 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)) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (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 = forall a. a -> Maybe a
Just Proxy
p }
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
hive = hKEY_CURRENT_USER
path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"
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
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
(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
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
if (isURLlocal url && hasLocal exceptions) || (url `S8.isInfixOf` (S8.pack exceptions)) then Nothing
else Just proxy
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 :: 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
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 :: Eq a => a -> [a] -> ([a],[a])
chopAtDelim elt xs =
case break (==elt) xs of
(_,[]) -> (xs,[])
(as,_:bs) -> (as,bs)
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
#endif
envName :: ProxyProtocol -> EnvName
envName :: ProxyProtocol -> Text
envName ProxyProtocol
proto = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ProxyProtocol
proto forall a. [a] -> [a] -> [a]
++ String
"_proxy"
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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [(String, String)]
env
lookupEnvVar :: Text -> Maybe String
lookupEnvVar Text
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> String
T.unpack Text
n) [(String, String)]
env forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
A.<|> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
Just String
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
Just String
str -> do
let invalid :: IO a
invalid = forall a. HttpExceptionContent -> IO a
throwHttp 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) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. IO a
invalid forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
let allowedScheme :: a -> Bool
allowedScheme a
x = a
x forall a. Eq a => a -> a -> Bool
== a
"http:"
URI
uri <- case String -> Maybe URI
U.parseURI String
str of
Just URI
u | forall {a}. (Eq a, IsString a) => a -> Bool
allowedScheme (URI -> String
U.uriScheme URI
u) -> forall (m :: * -> *) a. Monad m => a -> m a
return URI
u
Maybe URI
_ -> String -> Maybe URI
U.parseURI forall a b. (a -> b) -> a -> b
$ String
"http://" forall a. [a] -> [a] -> [a]
++ String
str
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall {a}. (Eq a, IsString a) => a -> Bool
allowedScheme forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriScheme URI
uri
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
U.uriPath URI
uri) Bool -> Bool -> Bool
|| URI -> String
U.uriPath URI
uri forall a. Eq a => a -> a -> Bool
== String
"/"
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ URI -> String
U.uriQuery URI
uri
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null 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
"" -> forall a. a -> Maybe a
Just Int
80
Char
':':String
rest ->
case forall a. Integral a => Reader a
decimal forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
rest of
Right (Int
p, Text
"") -> forall a. a -> Maybe a
Just Int
p
Either String (Int, Text)
_ -> forall a. Maybe a
Nothing
String
_ -> forall a. Maybe a
Nothing
forall a. a -> Maybe a
Just (UserName -> Int -> Proxy
Proxy (String -> UserName
S8.pack forall a b. (a -> b) -> a -> b
$ URIAuth -> String
U.uriRegName URIAuth
auth) Int
port', URI -> Maybe (UserName, UserName)
extractBasicAuthInfo URI
uri)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \UserName
hostRequest ->
if UserName
hostRequest forall {t :: * -> *}. Foldable t => UserName -> t UserName -> Bool
`hasDomainSuffixIn` [UserName]
noProxyDomains
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just 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 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 forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> UserName -> UserName
S8.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
' ') UserName
suffix | UserName
suffix <- Char -> UserName -> [UserName]
S8.split Char
',' (String -> UserName
S8.pack (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' = 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'))