diff --git a/Utility/HttpManagerRestricted.hs b/Utility/HttpManagerRestricted.hs deleted file mode 100644 index b0b4e51451..0000000000 --- a/Utility/HttpManagerRestricted.hs +++ /dev/null @@ -1,300 +0,0 @@ -{- | Restricted `ManagerSettings` for - - - - Copyright 2018 Joey Hess - - - - Portions from http-client-tls Copyright (c) 2013 Michael Snoyman - - - - License: MIT - -} - -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-} - --- This is a vendored copy of Network.HTTP.Client.Restricted from the --- http-client-restricted package, and will be removed once that package --- is available in all build environments. -module Utility.HttpManagerRestricted ( - Restriction, - checkAddressRestriction, - addressRestriction, - mkRestrictedManagerSettings, - ConnectionRestricted(..), - connectionRestricted, - ProxyRestricted(..), - IPAddrString, -) where - -import Network.HTTP.Client -import Network.HTTP.Client.Internal (ManagerSettings(..), Connection, runProxyOverride) -import Network.HTTP.Client.TLS (mkManagerSettingsContext) -import Network.Socket -import Network.BSD (getProtocolNumber) -import Control.Exception -import qualified Network.Connection as NC -import qualified Data.ByteString.UTF8 as BU -import Data.Maybe -import Data.Default -import Data.Typeable -import qualified Data.Semigroup as Sem -import Data.Monoid -import Control.Applicative -import Prelude - --- | Configuration of which HTTP connections to allow and which to --- restrict. -data Restriction = Restriction - { checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted - } - --- | Decide if a HTTP connection is allowed based on the IP address --- of the server. --- --- After the restriction is checked, the same IP address is used --- to connect to the server. This avoids DNS rebinding attacks --- being used to bypass the restriction. --- --- > myRestriction :: Restriction --- > myRestriction = addressRestriction $ \addr -> --- > if isPrivateAddress addr --- > then Just $ connectionRestricted --- > ("blocked connection to private IP address " ++) --- > else Nothing -addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction -addressRestriction f = mempty { checkAddressRestriction = f } - -appendRestrictions :: Restriction -> Restriction -> Restriction -appendRestrictions a b = Restriction - { checkAddressRestriction = \addr -> - checkAddressRestriction a addr <|> checkAddressRestriction b addr - } - --- | mempty does not restrict HTTP connections in any way -instance Monoid Restriction where - mempty = Restriction - { checkAddressRestriction = \_ -> Nothing - } - -instance Sem.Semigroup Restriction where - (<>) = appendRestrictions - --- | Value indicating that a connection was restricted, and giving the --- reason why. -data ConnectionRestricted = ConnectionRestricted String - deriving (Show, Typeable) - -instance Exception ConnectionRestricted - --- | A string containing an IP address, for display to a user. -type IPAddrString = String - --- | Constructs a ConnectionRestricted, passing the function a string --- containing the IP address of the HTTP server. -connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted -connectionRestricted mkmessage = - ConnectionRestricted . mkmessage . showSockAddress . addrAddress - --- | Value indicating that the http proxy will not be used. -data ProxyRestricted = ProxyRestricted - deriving (Show) - --- Adjusts a ManagerSettings to enforce a Restriction. The restriction --- will be checked each time a Request is made, and for each redirect --- followed. --- --- This overrides the `managerRawConnection` --- and `managerTlsConnection` with its own implementations that check --- the Restriction. They should otherwise behave the same as the --- ones provided by http-client-tls. --- --- This function is not exported, because using it with a ManagerSettings --- produced by something other than http-client-tls would result in --- surprising behavior, since its connection methods would not be used. --- --- The http proxy is also checked against the Restriction, and if --- access to it is blocked, the http proxy will not be used. -restrictManagerSettings - :: Maybe NC.ConnectionContext - -> Maybe NC.TLSSettings - -> Restriction - -> ManagerSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -restrictManagerSettings mcontext mtls cfg base = restrictProxy cfg $ base - { managerRawConnection = restrictedRawConnection cfg - , managerTlsConnection = restrictedTlsConnection mcontext mtls cfg - , managerWrapException = wrapOurExceptions base - } - --- | Makes a TLS-capable ManagerSettings with a Restriction applied to it. --- --- The Restriction will be checked each time a Request is made, and for --- each redirect followed. --- --- Aside from checking the Restriction, it should behave the same as --- `Network.HTTP.Client.TLS.mkManagerSettingsContext` --- from http-client-tls. --- --- > main = do --- > manager <- newManager . fst --- > =<< mkRestrictedManagerSettings myRestriction Nothing Nothing --- > request <- parseRequest "http://httpbin.org/get" --- > response <- httpLbs request manager --- > print $ responseBody response --- --- The HTTP proxy is also checked against the Restriction, and will not be --- used if the Restriction does not allow it. Just ProxyRestricted --- is returned when the HTTP proxy has been restricted. --- --- See `mkManagerSettingsContext` for why --- it can be useful to provide a `NC.ConnectionContext`. --- --- Note that SOCKS is not supported. -mkRestrictedManagerSettings - :: Restriction - -> Maybe NC.ConnectionContext - -> Maybe NC.TLSSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -mkRestrictedManagerSettings cfg mcontext mtls = - restrictManagerSettings mcontext mtls cfg $ - mkManagerSettingsContext mcontext (fromMaybe def mtls) Nothing - -restrictProxy - :: Restriction - -> ManagerSettings - -> IO (ManagerSettings, Maybe ProxyRestricted) -restrictProxy cfg base = do - http_proxy_addr <- getproxyaddr False - https_proxy_addr <- getproxyaddr True - let (http_proxy, http_r) = mkproxy http_proxy_addr - let (https_proxy, https_r) = mkproxy https_proxy_addr - let ms = managerSetInsecureProxy http_proxy $ - managerSetSecureProxy https_proxy base - return (ms, http_r <|> https_r) - where - -- This does not use localhost because http-client may choose - -- not to use the proxy for localhost. - testnetip = "198.51.100.1" - dummyreq https = parseRequest_ $ - "http" ++ (if https then "s" else "") ++ "://" ++ testnetip - - getproxyaddr https = extractproxy >>= \case - Nothing -> return Nothing - Just p -> do - proto <- getProtocolNumber "tcp" - let serv = show (proxyPort p) - let hints = defaultHints - { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream - } - let h = BU.toString $ proxyHost p - getAddrInfo (Just hints) (Just h) (Just serv) >>= \case - [] -> return Nothing - (addr:_) -> return $ Just addr - where - -- These contortions are necessary until this issue - -- is fixed: - -- https://github.com/snoyberg/http-client/issues/355 - extractproxy = do - let po = if https - then managerProxySecure base - else managerProxyInsecure base - f <- runProxyOverride po https - return $ proxy $ f $ dummyreq https - - mkproxy Nothing = (noProxy, Nothing) - mkproxy (Just proxyaddr) = case checkAddressRestriction cfg proxyaddr of - Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing) - Just _ -> (noProxy, Just ProxyRestricted) - - addrtoproxy addr = case addr of - SockAddrInet pn _ -> mk pn - SockAddrInet6 pn _ _ _ -> mk pn - _ -> noProxy - where - mk pn = useProxy Network.HTTP.Client.Proxy - { proxyHost = BU.fromString (showSockAddress addr) - , proxyPort = fromIntegral pn - } - -wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a -wrapOurExceptions base req a = - let wrapper se - | Just (_ :: ConnectionRestricted) <- fromException se = - toException $ HttpExceptionRequest req $ - InternalException se - | otherwise = se - in managerWrapException base req (handle (throwIO . wrapper) a) - -restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -restrictedRawConnection cfg = getConnection cfg Nothing Nothing - -restrictedTlsConnection :: Maybe NC.ConnectionContext -> Maybe NC.TLSSettings -> Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -restrictedTlsConnection mcontext mtls cfg = - getConnection cfg (Just (fromMaybe def mtls)) mcontext - --- Based on Network.HTTP.Client.TLS.getTlsConnection. --- --- Checks the Restriction --- --- Does not support SOCKS. -getConnection - :: Restriction - -> Maybe NC.TLSSettings - -> Maybe NC.ConnectionContext - -> IO (Maybe HostAddress -> String -> Int -> IO Connection) -getConnection cfg tls mcontext = do - context <- maybe NC.initConnectionContext return mcontext - return $ \_ha h p -> bracketOnError - (go context h p) - NC.connectionClose - convertConnection - where - go context h p = do - let connparams = NC.ConnectionParams - { NC.connectionHostname = h - , NC.connectionPort = fromIntegral p - , NC.connectionUseSecure = tls - , NC.connectionUseSocks = Nothing -- unsupprted - } - proto <- getProtocolNumber "tcp" - let serv = show p - let hints = defaultHints - { addrFlags = [AI_ADDRCONFIG] - , addrProtocol = proto - , addrSocketType = Stream - } - addrs <- getAddrInfo (Just hints) (Just h) (Just serv) - bracketOnError - (firstSuccessful $ map tryToConnect addrs) - close - (\sock -> NC.connectFromSocket context sock connparams) - where - tryToConnect addr = case checkAddressRestriction cfg addr of - Nothing -> bracketOnError - (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - close - (\sock -> connect sock (addrAddress addr) >> return sock) - Just r -> throwIO r - firstSuccessful [] = throwIO $ NC.HostNotResolved h - firstSuccessful (a:as) = a `catch` \(e ::IOException) -> - case as of - [] -> throwIO e - _ -> firstSuccessful as - --- Copied from Network.HTTP.Client.TLS, unfortunately not exported. -convertConnection :: NC.Connection -> IO Connection -convertConnection conn = makeConnection - (NC.connectionGetChunk conn) - (NC.connectionPut conn) - -- Closing an SSL connection gracefully involves writing/reading - -- on the socket. But when this is called the socket might be - -- already closed, and we get a @ResourceVanished@. - (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ()) - --- For ipv4 and ipv6, the string will contain only the IP address, --- omitting the port that the Show instance includes. -showSockAddress :: SockAddr -> IPAddrString -showSockAddress a@(SockAddrInet _ _) = - takeWhile (/= ':') $ show a -showSockAddress a@(SockAddrInet6 _ _ _ _) = - takeWhile (/= ']') $ drop 1 $ show a -showSockAddress a = show a