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
parent
28720c795f
commit
40e8358284
3 changed files with 161 additions and 20 deletions
46
COPYRIGHT
46
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:
|
||||
.
|
||||
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
|
||||
|
|
|
|||
132
Utility/HttpManagerRestricted.hs
Normal file
132
Utility/HttpManagerRestricted.hs
Normal 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 ())
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue