merge from http-client-restricted

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.

Annex/Url.hs

@@ -22,6 +22,8 @@ import Utility.HttpManagerRestricted
 import qualified BuildInfo
 
 import Network.Socket
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
 
 defaultUserAgent :: U.UserAgent
 defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion
@@ -62,7 +64,8 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case
 				then U.DownloadWithConduit $
 					U.DownloadWithCurlRestricted mempty
 				else U.DownloadWithCurl curlopts
-			manager <- liftIO $ U.newManager U.managerSettings
+			manager <- liftIO $ U.newManager $ 
+				avoidtimeout $ tlsManagerSettings
 			return (urldownloader, manager)
 		allowedaddrs -> do
 			addrmatcher <- liftIO $ 
@@ -76,24 +79,28 @@ getUrlOptions = Annex.getState Annex.urloptions >>= \case
 				| isLoopbackAddress addr = False
 				| isPrivateAddress addr = False
 				| otherwise = True
-			let connectionrestricted = addrConnectionRestricted 
+			let connectionrestricted = connectionRestricted 
 				("Configuration of annex.security.allowed-ip-addresses does not allow accessing address " ++)
-			let r = Restriction
+			let r = addressRestriction $ \addr ->
-				{ checkAddressRestriction = \addr ->
+				if isallowed (addrAddress addr)
-					if isallowed (addrAddress addr)
+					then Nothing
-						then Nothing
+					else Just (connectionrestricted addr)
-						else Just (connectionrestricted addr)
-				}
 			(settings, pr) <- liftIO $ 
-				restrictManagerSettings r U.managerSettings
+				mkRestrictedManagerSettings r Nothing Nothing
 			case pr of
 				Nothing -> return ()
 				Just ProxyRestricted -> toplevelWarning True
 					"http proxy settings not used due to annex.security.allowed-ip-addresses configuration"
-			manager <- liftIO $ U.newManager settings
+			manager <- liftIO $ U.newManager $ 
+				avoidtimeout settings
 			let urldownloader = U.DownloadWithConduit $
 				U.DownloadWithCurlRestricted r
 			return (urldownloader, manager)
+	
+	-- http-client defailts to timing out a request after 30 seconds
+	-- or so, but some web servers are slower and git-annex has its own
+	-- separate timeout controls, so disable that.
+	avoidtimeout s = s { managerResponseTimeout = responseTimeoutNone }
 
 ipAddressesUnlimited :: Annex Bool
 ipAddressesUnlimited = 

Utility/HttpManagerRestricted.hs

@@ -1,7 +1,7 @@
-{- | Restricted Manager for http-client-tls
+{- | 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
@@ -10,10 +10,12 @@
 {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-}
 
 module Utility.HttpManagerRestricted (
-	restrictManagerSettings,
+	Restriction,
-	Restriction(..),
+	checkAddressRestriction,
+	addressRestriction,
+	mkRestrictedManagerSettings,
 	ConnectionRestricted(..),
-	addrConnectionRestricted,
+	connectionRestricted,
 	ProxyRestricted(..),
 	IPAddrString,
 ) where
@@ -21,22 +23,42 @@ module Utility.HttpManagerRestricted (
 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 Control.Applicative
 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 ->
@@ -52,39 +74,86 @@ instance Monoid Restriction where
 instance Sem.Semigroup Restriction where
 	(<>) = appendRestrictions
 
--- | An exception used to indicate that the connection was restricted.
+-- | 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.
+-- containing the IP address of the HTTP server.
-addrConnectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted
+connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted
-addrConnectionRestricted mkmessage = 
+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
+-- 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
-	:: Restriction
+	:: Maybe NC.ConnectionContext
+	-> Maybe NC.TLSSettings
+	-> Restriction
 	-> ManagerSettings
 	-> IO (ManagerSettings, Maybe ProxyRestricted)
-restrictManagerSettings cfg base = restrictProxy cfg $ base
+restrictManagerSettings mcontext mtls cfg base = restrictProxy cfg $ base
 	{ managerRawConnection = restrictedRawConnection cfg
-	, managerTlsConnection = restrictedTlsConnection 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
@@ -154,27 +223,24 @@ wrapOurExceptions base req a =
 	 in managerWrapException base req (handle (throwIO . wrapper) a)
 
 restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
-restrictedRawConnection cfg = getConnection cfg Nothing
+restrictedRawConnection cfg = getConnection cfg Nothing Nothing
-
-restrictedTlsConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
-restrictedTlsConnection cfg = getConnection cfg $
-	-- It's not possible to access the TLSSettings
-	-- used in the base ManagerSettings. So, use the default
-	-- value, which is the same thing http-client-tls defaults to.
-	-- Since changing from the default settings can only make TLS
-	-- less secure, this is not a big problem.
-	Just def
-
 
+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 -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
+getConnection
-getConnection cfg tls = do
+	:: Restriction
-	context <- NC.initConnectionContext
+	-> 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

Utility/Url.hs

@@ -11,7 +11,6 @@
 
 module Utility.Url (
 	newManager,
-	managerSettings,
 	URLString,
 	UserAgent,
 	Scheme,
@@ -62,10 +61,6 @@ import Data.Conduit
 import Text.Read
 import System.Log.Logger
 
-managerSettings :: ManagerSettings
-managerSettings = tlsManagerSettings
-	{ managerResponseTimeout = responseTimeoutNone }
-
 type URLString = String
 
 type Headers = [String]
@@ -103,7 +98,7 @@ defUrlOptions = UrlOptions
 	<*> pure []
 	<*> pure (DownloadWithConduit (DownloadWithCurlRestricted mempty))
 	<*> pure id
-	<*> newManager managerSettings
+	<*> newManager tlsManagerSettings
 	<*> pure (S.fromList $ map mkScheme ["http", "https", "ftp"])
 
 mkUrlOptions :: Maybe UserAgent -> Headers -> UrlDownloader -> Manager -> S.Set Scheme -> UrlOptions