7fd650355e
I made some improvements to its API after splitting it out of git-annex, so merge those back in. This is groundwork for removing the embedded copy of it and depending on it. Also moved the managerResponseTimeout disabling to Annex.Url as it's git-annex specific. This commit was sponsored by Ethan Aubin on Patreon.
298 lines
10 KiB
Haskell
298 lines
10 KiB
Haskell
{- | Restricted `ManagerSettings` for <https://haskell-lang.org/library/http-client>
|
|
-
|
|
- Copyright 2018 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Portions from http-client-tls Copyright (c) 2013 Michael Snoyman
|
|
-
|
|
- License: MIT
|
|
-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-}
|
|
|
|
module Utility.HttpManagerRestricted (
|
|
Restriction,
|
|
checkAddressRestriction,
|
|
addressRestriction,
|
|
mkRestrictedManagerSettings,
|
|
ConnectionRestricted(..),
|
|
connectionRestricted,
|
|
ProxyRestricted(..),
|
|
IPAddrString,
|
|
) where
|
|
|
|
import Network.HTTP.Client
|
|
import Network.HTTP.Client.Internal
|
|
(ManagerSettings(..), Connection, runProxyOverride, makeConnection)
|
|
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
|