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.
This commit is contained in:
Joey Hess 2018-06-16 14:18:29 -04:00
parent 28720c795f
commit 40e8358284
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 161 additions and 20 deletions

View file

@ -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:
.
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 is in the MIT section below.
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

View file

@ -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 ())

View file

@ -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