add Utility.HttpManagerRestricted

This is a clean way to add IP address restrictions to http-client, and
any library using it.
See https://github.com/snoyberg/http-client/issues/354#issuecomment-397830259

Some code from http-client and http-client-tls was copied in and
modified. Credited its author accordingly, and used the same MIT license.

The restrictions don't apply to http proxies. If using http proxies is a
problem, http-client already has a way to disable them.
SOCKS support is not included. As far as I can tell, http-client-tls
does not support SOCKS by default, and so git-annex never has.

The additional dependencies are free; git-annex already transitively
depended on them via http-conduit.

This commit was sponsored by Eric Drechsel on Patreon.

COPYRIGHT

@@ -24,6 +24,11 @@ Copyright: 2011 Bas van Dijk & Roel van Dijk
            2012, 2013 Joey Hess <id@joeyh.name>
 License: BSD-2-clause
 
+Files: Utility/HttpManagerRestricted.hs
+Copyright: 2018 Joey Hess <id@joeyh.name>
+           2013 Michael Snoyman
+License: MIT
+
 Files: Utility/*
 Copyright: 2012-2018 Joey Hess <id@joeyh.name>
 License: BSD-2-clause
@@ -51,26 +56,7 @@ Copyright: © 2005-2011 by John Resig, Branden Aaron & Jörn Zaefferer
 License: MIT or GPL-2
  The full text of version 2 of the GPL is distributed in
  /usr/share/common-licenses/GPL-2 on Debian systems. The text of the MIT
- license follows:
+ license is in the MIT section below.
- .
- Permission is hereby granted, free of charge, to any person obtaining
- a copy of this software and associated documentation files (the
- "Software"), to deal in the Software without restriction, including
- without limitation the rights to use, copy, modify, merge, publish,
- distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is furnished to do so, subject to
- the following conditions:
- .
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
- .
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 Files: static/*/bootstrap* static/*/glyphicons-halflings*
 Copyright: 2012-2014 Twitter, Inc.
@@ -153,6 +139,26 @@ License: BSD-2-clause
  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.
+ 
+License: MIT
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ "Software"), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+ .
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+ .
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 License: AGPL-3+
                       GNU AFFERO GENERAL PUBLIC LICENSE

Utility/HttpManagerRestricted.hs

@@ -0,0 +1,132 @@
+{- | Restricted Manager for http-client-tls
+ -
+ - Copyright 2018 Joey Hess <id@joeyh.name>
+ - 
+ - Portions from http-client-tls Copyright (c) 2013 Michael Snoyman
+ -
+ - License: MIT
+ -}
+
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+
+module Utility.HttpManagerRestricted (
+	restrictManagerSettings,
+	Restriction(..),
+	ConnectionRestricted(..),
+	addrConnectionRestricted,
+) where
+
+import Network.HTTP.Client
+import Network.HTTP.Client.Internal (ManagerSettings(..), Connection)
+import Network.HTTP.Client.TLS
+import Network.Socket
+import Network.BSD (getProtocolNumber)
+import Control.Exception
+import qualified Network.Connection as NC
+import Data.ByteString (ByteString)
+import Data.Default
+import Data.Typeable
+
+data Restriction = Restriction
+	{ addressRestriction :: AddrInfo -> Maybe ConnectionRestricted
+	}
+
+data ConnectionRestricted = ConnectionRestricted String
+	deriving (Show, Typeable)
+
+instance Exception ConnectionRestricted
+
+addrConnectionRestricted :: AddrInfo -> ConnectionRestricted
+addrConnectionRestricted addr = ConnectionRestricted $ unwords
+	 [ "Configuration does not allow accessing address"
+	 , case addrAddress addr of
+	 	a@(SockAddrInet _ _) ->
+			takeWhile (/= ':') $ show a
+		a@(SockAddrInet6 _ _ _ _) -> 
+			takeWhile (/= ']') $ drop 1 $ show a
+	 ]
+
+-- | Adjusts a ManagerSettings to check a Restriction.
+--
+-- Note that connections to http proxies are not checked.
+-- Use `managerSetProxy noProxy` to prevent connections through http
+-- proxies.
+restrictManagerSettings ::  Restriction -> ManagerSettings -> ManagerSettings
+restrictManagerSettings cfg base = base
+	{ managerRawConnection = restrictedRawConnection cfg
+	, managerTlsConnection = restrictedTlsConnection cfg
+	, managerWrapException = \req ->
+		let wrapper se
+			| Just (_ :: ConnectionRestricted) <- fromException se = 
+		         	toException $ HttpExceptionRequest req $
+					InternalException se
+			| otherwise = se
+		 in handle $ throwIO . wrapper
+	}
+
+restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
+restrictedRawConnection cfg = getConnection cfg 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
+
+-- 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 cfg tls = do
+	context <- NC.initConnectionContext
+	return $ \_ha host port -> bracketOnError
+		(go context host port)
+		NC.connectionClose
+		convertConnection
+   where
+	go context host port = do
+		let connparams = NC.ConnectionParams
+			{ NC.connectionHostname = host
+			, NC.connectionPort = fromIntegral port
+			, NC.connectionUseSecure = tls
+			, NC.connectionUseSocks = Nothing -- unsupprted
+			}
+		proto <- getProtocolNumber "tcp"
+		let serv = show port
+		let hints = defaultHints
+			{ addrFlags = [AI_ADDRCONFIG]
+			, addrProtocol = proto
+			, addrSocketType = Stream
+			}
+		addrs <- getAddrInfo (Just hints) (Just host) (Just serv)
+		bracketOnError
+			(firstSuccessful $ map tryToConnect addrs)
+			close
+			(\sock -> NC.connectFromSocket context sock connparams)
+	  where
+		tryToConnect addr = case addressRestriction 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 host
+		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 ())

git-annex.cabal

@@ -340,7 +340,9 @@ Executable git-annex
    bloomfilter,
    edit-distance,
    resourcet,
+   connection,
    http-client,
+   http-client-tls,
    http-types (>= 0.7),
    http-conduit (>= 2.0),
    conduit,
@@ -1032,6 +1034,7 @@ Executable git-annex
     Utility.Gpg
     Utility.Hash
     Utility.HtmlDetect
+    Utility.HttpManagerRestricted
     Utility.HumanNumber
     Utility.HumanTime
     Utility.InodeCache