{-# 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 HTTPProxy = "http" show HTTPSProxy = "https" data ProxySettings = ProxySettings { _proxyHost :: Proxy, _proxyAuth :: Maybe (UserName, Password) } deriving Show httpProtocol :: Bool -> ProxyProtocol httpProtocol True = HTTPSProxy httpProtocol False = HTTPProxy data EnvHelper = EHFromRequest | EHNoProxy | EHUseProxy Proxy headJust :: [Maybe a] -> Maybe a headJust [] = Nothing headJust (Nothing:xs) = headJust xs headJust ((y@(Just _)):_) = y systemProxyHelper :: Maybe T.Text -> ProxyProtocol -> EnvHelper -> IO (Request -> Request) systemProxyHelper envOveride prot eh = do let envName' Nothing = envName prot envName' (Just name) = name modifier <- envHelper (envName' 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 = [modifier] #endif let chooseMod :: Request -> Maybe ProxySettings chooseMod req = headJust . map (\m -> m . host $ req) $ modifiers noEnvProxy = case eh of EHFromRequest -> id EHNoProxy -> \req -> req { proxy = Nothing } EHUseProxy p -> \req -> req { proxy = Just p } let result req = toRequest . chooseMod $ req where toRequest Nothing = noEnvProxy req toRequest (Just (ProxySettings p muserpass)) = maybe id (uncurry applyBasicProxyAuth) muserpass req { proxy = Just p } return 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 = "" `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 proto = T.pack $ show proto ++ "_proxy" -- Extract proxy settings from environment variables. This is a standard way in Linux. envHelper :: EnvName -> IO (HostAddress -> Maybe ProxySettings) envHelper name = do env <- getEnvironment let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env lookupEnvVar n = lookup (T.unpack n) env A.<|> Map.lookup n lenv noProxyDomains = domainSuffixes (lookupEnvVar "no_proxy") case lookupEnvVar name of Nothing -> return . const $ Nothing Just "" -> return . const $ Nothing Just str -> do let invalid = throwHttp $ InvalidProxyEnvironmentVariable name (T.pack str) (p, muserpass) <- maybe invalid return $ do let allowedScheme x = x == "http:" uri <- case U.parseURI str of Just u | allowedScheme (U.uriScheme u) -> return u _ -> U.parseURI $ "http://" ++ str guard $ allowedScheme $ U.uriScheme uri guard $ null (U.uriPath uri) || U.uriPath uri == "/" guard $ null $ U.uriQuery uri guard $ null $ U.uriFragment uri auth <- U.uriAuthority uri port' <- case U.uriPort auth of "" -> Just 80 ':':rest -> case decimal $ T.pack rest of Right (p, "") -> Just p _ -> Nothing _ -> Nothing Just (Proxy (S8.pack $ U.uriRegName auth) port', extractBasicAuthInfo uri) return $ \hostRequest -> if hostRequest `hasDomainSuffixIn` noProxyDomains then Nothing else Just $ ProxySettings p muserpass where prefixed s | S8.head s == '.' = s | otherwise = S8.cons '.' s domainSuffixes Nothing = [] domainSuffixes (Just "") = [] domainSuffixes (Just no_proxy) = [prefixed $ S8.dropWhile (== ' ') suffix | suffix <- S8.split ',' (S8.pack (map toLower no_proxy)), not (S8.null suffix)] hasDomainSuffixIn host' = any (`S8.isSuffixOf` prefixed (S8.map toLower host'))