{- | 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 Network.HTTP.Client.Restricted (
	Restriction,
	checkAddressRestriction,
	addressRestriction,
	mkRestrictedManagerSettings,
	ConnectionRestricted(..),
	connectionRestricted,
	ProxyRestricted(..),
	IPAddrString,
) where

import Network.HTTP.Client
import Network.HTTP.Client.Internal (ManagerSettings(..), Connection, runProxyOverride)
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
	{ Restriction -> AddrInfo -> Maybe ConnectionRestricted
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 :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
addressRestriction AddrInfo -> Maybe ConnectionRestricted
f = Restriction
forall a. Monoid a => a
mempty { checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction = AddrInfo -> Maybe ConnectionRestricted
f }

appendRestrictions :: Restriction -> Restriction -> Restriction
appendRestrictions :: Restriction -> Restriction -> Restriction
appendRestrictions Restriction
a Restriction
b = Restriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
Restriction
	{ checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction = \AddrInfo
addr ->
		Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
a AddrInfo
addr Maybe ConnectionRestricted
-> Maybe ConnectionRestricted -> Maybe ConnectionRestricted
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
b AddrInfo
addr
	}

-- | mempty does not restrict HTTP connections in any way
instance Monoid Restriction where
	mempty :: Restriction
mempty = Restriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
Restriction
		{ checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction = \AddrInfo
_ -> Maybe ConnectionRestricted
forall a. Maybe a
Nothing
		}

instance Sem.Semigroup Restriction where
	<> :: Restriction -> Restriction -> Restriction
(<>) = Restriction -> Restriction -> Restriction
appendRestrictions

-- | Value indicating that a connection was restricted, and giving the
-- reason why.
data ConnectionRestricted = ConnectionRestricted String
	deriving (Int -> ConnectionRestricted -> ShowS
[ConnectionRestricted] -> ShowS
ConnectionRestricted -> String
(Int -> ConnectionRestricted -> ShowS)
-> (ConnectionRestricted -> String)
-> ([ConnectionRestricted] -> ShowS)
-> Show ConnectionRestricted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionRestricted] -> ShowS
$cshowList :: [ConnectionRestricted] -> ShowS
show :: ConnectionRestricted -> String
$cshow :: ConnectionRestricted -> String
showsPrec :: Int -> ConnectionRestricted -> ShowS
$cshowsPrec :: Int -> ConnectionRestricted -> ShowS
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 :: ShowS -> AddrInfo -> ConnectionRestricted
connectionRestricted ShowS
mkmessage = 
	String -> ConnectionRestricted
ConnectionRestricted (String -> ConnectionRestricted)
-> (AddrInfo -> String) -> AddrInfo -> ConnectionRestricted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkmessage ShowS -> (AddrInfo -> String) -> AddrInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SockAddr -> String
showSockAddress (SockAddr -> String)
-> (AddrInfo -> SockAddr) -> AddrInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrInfo -> SockAddr
addrAddress

-- | Value indicating that the http proxy will not be used.
data ProxyRestricted = ProxyRestricted
	deriving (Int -> ProxyRestricted -> ShowS
[ProxyRestricted] -> ShowS
ProxyRestricted -> String
(Int -> ProxyRestricted -> ShowS)
-> (ProxyRestricted -> String)
-> ([ProxyRestricted] -> ShowS)
-> Show ProxyRestricted
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProxyRestricted] -> ShowS
$cshowList :: [ProxyRestricted] -> ShowS
show :: ProxyRestricted -> String
$cshow :: ProxyRestricted -> String
showsPrec :: Int -> ProxyRestricted -> ShowS
$cshowsPrec :: Int -> ProxyRestricted -> ShowS
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 :: Maybe ConnectionContext
-> Maybe TLSSettings
-> Restriction
-> ManagerSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
restrictManagerSettings Maybe ConnectionContext
mcontext Maybe TLSSettings
mtls Restriction
cfg ManagerSettings
base = Restriction
-> ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted)
restrictProxy Restriction
cfg (ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted))
-> ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted)
forall a b. (a -> b) -> a -> b
$ ManagerSettings
base
	{ managerRawConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerRawConnection = Restriction
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedRawConnection Restriction
cfg
	, managerTlsConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerTlsConnection = Maybe ConnectionContext
-> Maybe TLSSettings
-> Restriction
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedTlsConnection Maybe ConnectionContext
mcontext Maybe TLSSettings
mtls Restriction
cfg
	, managerWrapException :: forall a. Request -> IO a -> IO a
managerWrapException = ManagerSettings -> Request -> IO a -> IO a
forall a. ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions ManagerSettings
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 :: Restriction
-> Maybe ConnectionContext
-> Maybe TLSSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
mkRestrictedManagerSettings Restriction
cfg Maybe ConnectionContext
mcontext Maybe TLSSettings
mtls =
	Maybe ConnectionContext
-> Maybe TLSSettings
-> Restriction
-> ManagerSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
restrictManagerSettings Maybe ConnectionContext
mcontext Maybe TLSSettings
mtls Restriction
cfg (ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted))
-> ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted)
forall a b. (a -> b) -> a -> b
$
		Maybe ConnectionContext
-> TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettingsContext Maybe ConnectionContext
mcontext (TLSSettings -> Maybe TLSSettings -> TLSSettings
forall a. a -> Maybe a -> a
fromMaybe TLSSettings
forall a. Default a => a
def Maybe TLSSettings
mtls) Maybe SockSettings
forall a. Maybe a
Nothing

restrictProxy
	:: Restriction
	-> ManagerSettings
	-> IO (ManagerSettings, Maybe ProxyRestricted)
restrictProxy :: Restriction
-> ManagerSettings -> IO (ManagerSettings, Maybe ProxyRestricted)
restrictProxy Restriction
cfg ManagerSettings
base = do	
	Maybe AddrInfo
http_proxy_addr <- Bool -> IO (Maybe AddrInfo)
getproxyaddr Bool
False
	Maybe AddrInfo
https_proxy_addr <- Bool -> IO (Maybe AddrInfo)
getproxyaddr Bool
True
	let (ProxyOverride
http_proxy, Maybe ProxyRestricted
http_r) = Maybe AddrInfo -> (ProxyOverride, Maybe ProxyRestricted)
mkproxy Maybe AddrInfo
http_proxy_addr
	let (ProxyOverride
https_proxy, Maybe ProxyRestricted
https_r) = Maybe AddrInfo -> (ProxyOverride, Maybe ProxyRestricted)
mkproxy Maybe AddrInfo
https_proxy_addr
	let ms :: ManagerSettings
ms = ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetInsecureProxy ProxyOverride
http_proxy (ManagerSettings -> ManagerSettings)
-> ManagerSettings -> ManagerSettings
forall a b. (a -> b) -> a -> b
$ 
		ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetSecureProxy ProxyOverride
https_proxy ManagerSettings
base
	(ManagerSettings, Maybe ProxyRestricted)
-> IO (ManagerSettings, Maybe ProxyRestricted)
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagerSettings
ms, Maybe ProxyRestricted
http_r Maybe ProxyRestricted
-> Maybe ProxyRestricted -> Maybe ProxyRestricted
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProxyRestricted
https_r)
  where
	-- This does not use localhost because http-client may choose
	-- not to use the proxy for localhost.
	testnetip :: String
testnetip = String
"198.51.100.1"
	dummyreq :: Bool -> Request
dummyreq Bool
https = String -> Request
parseRequest_ (String -> Request) -> String -> Request
forall a b. (a -> b) -> a -> b
$
		String
"http" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
https then String
"s" else String
"") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"://" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
testnetip

	getproxyaddr :: Bool -> IO (Maybe AddrInfo)
getproxyaddr Bool
https = IO (Maybe Proxy)
extractproxy IO (Maybe Proxy)
-> (Maybe Proxy -> IO (Maybe AddrInfo)) -> IO (Maybe AddrInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
		Maybe Proxy
Nothing -> Maybe AddrInfo -> IO (Maybe AddrInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AddrInfo
forall a. Maybe a
Nothing
		Just Proxy
p -> do
			ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
			let serv :: String
serv = Int -> String
forall a. Show a => a -> String
show (Proxy -> Int
proxyPort Proxy
p)
			let hints :: AddrInfo
hints = AddrInfo
defaultHints
				{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
				, addrProtocol :: ProtocolNumber
addrProtocol = ProtocolNumber
proto
				, addrSocketType :: SocketType
addrSocketType = SocketType
Stream
				}
			let h :: String
h = ByteString -> String
BU.toString (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Proxy -> ByteString
proxyHost Proxy
p
			Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
h) (String -> Maybe String
forall a. a -> Maybe a
Just String
serv) IO [AddrInfo]
-> ([AddrInfo] -> IO (Maybe AddrInfo)) -> IO (Maybe AddrInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
				[] -> Maybe AddrInfo -> IO (Maybe AddrInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AddrInfo
forall a. Maybe a
Nothing
				(AddrInfo
addr:[AddrInfo]
_) -> Maybe AddrInfo -> IO (Maybe AddrInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AddrInfo -> IO (Maybe AddrInfo))
-> Maybe AddrInfo -> IO (Maybe AddrInfo)
forall a b. (a -> b) -> a -> b
$ AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
addr
	  where
		-- These contortions are necessary until this issue
		-- is fixed:
		-- https://github.com/snoyberg/http-client/issues/355
		extractproxy :: IO (Maybe Proxy)
extractproxy = do
			let po :: ProxyOverride
po = if Bool
https
				then ManagerSettings -> ProxyOverride
managerProxySecure ManagerSettings
base
				else ManagerSettings -> ProxyOverride
managerProxyInsecure ManagerSettings
base
			Request -> Request
f <- ProxyOverride -> Bool -> IO (Request -> Request)
runProxyOverride ProxyOverride
po Bool
https
			Maybe Proxy -> IO (Maybe Proxy)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Proxy -> IO (Maybe Proxy))
-> Maybe Proxy -> IO (Maybe Proxy)
forall a b. (a -> b) -> a -> b
$ Request -> Maybe Proxy
proxy (Request -> Maybe Proxy) -> Request -> Maybe Proxy
forall a b. (a -> b) -> a -> b
$ Request -> Request
f (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Bool -> Request
dummyreq Bool
https
	
	mkproxy :: Maybe AddrInfo -> (ProxyOverride, Maybe ProxyRestricted)
mkproxy Maybe AddrInfo
Nothing = (ProxyOverride
noProxy, Maybe ProxyRestricted
forall a. Maybe a
Nothing)
	mkproxy (Just AddrInfo
proxyaddr) = case Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
cfg AddrInfo
proxyaddr of
		Maybe ConnectionRestricted
Nothing -> (SockAddr -> ProxyOverride
addrtoproxy (AddrInfo -> SockAddr
addrAddress AddrInfo
proxyaddr), Maybe ProxyRestricted
forall a. Maybe a
Nothing)
		Just ConnectionRestricted
_ -> (ProxyOverride
noProxy, ProxyRestricted -> Maybe ProxyRestricted
forall a. a -> Maybe a
Just ProxyRestricted
ProxyRestricted)
	
	addrtoproxy :: SockAddr -> ProxyOverride
addrtoproxy SockAddr
addr = case SockAddr
addr of
		SockAddrInet PortNumber
pn HostAddress
_ -> PortNumber -> ProxyOverride
forall a. Integral a => a -> ProxyOverride
mk PortNumber
pn
		SockAddrInet6 PortNumber
pn HostAddress
_ HostAddress6
_ HostAddress
_ -> PortNumber -> ProxyOverride
forall a. Integral a => a -> ProxyOverride
mk PortNumber
pn
		SockAddr
_ -> ProxyOverride
noProxy
	  where
		mk :: a -> ProxyOverride
mk a
pn = Proxy -> ProxyOverride
useProxy Proxy :: ByteString -> Int -> Proxy
Network.HTTP.Client.Proxy
			{ proxyHost :: ByteString
proxyHost = String -> ByteString
BU.fromString (SockAddr -> String
showSockAddress SockAddr
addr)
			, proxyPort :: Int
proxyPort = a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
pn
			}

wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions ManagerSettings
base Request
req IO a
a =
	let wrapper :: SomeException -> SomeException
wrapper SomeException
se
		| Just (ConnectionRestricted
_ :: ConnectionRestricted) <- SomeException -> Maybe ConnectionRestricted
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = 
	         	HttpException -> SomeException
forall e. Exception e => e -> SomeException
toException (HttpException -> SomeException) -> HttpException -> SomeException
forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req (HttpExceptionContent -> HttpException)
-> HttpExceptionContent -> HttpException
forall a b. (a -> b) -> a -> b
$
				SomeException -> HttpExceptionContent
InternalException SomeException
se
		| Bool
otherwise = SomeException
se
	 in ManagerSettings -> Request -> IO a -> IO a
ManagerSettings -> forall a. Request -> IO a -> IO a
managerWrapException ManagerSettings
base Request
req ((SomeException -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeException -> IO a)
-> (SomeException -> SomeException) -> SomeException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> SomeException
wrapper) IO a
a)

restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedRawConnection :: Restriction
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedRawConnection Restriction
cfg = Restriction
-> Maybe TLSSettings
-> Maybe ConnectionContext
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getConnection Restriction
cfg Maybe TLSSettings
forall a. Maybe a
Nothing Maybe ConnectionContext
forall a. Maybe a
Nothing

restrictedTlsConnection :: Maybe NC.ConnectionContext -> Maybe NC.TLSSettings -> Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedTlsConnection :: Maybe ConnectionContext
-> Maybe TLSSettings
-> Restriction
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedTlsConnection Maybe ConnectionContext
mcontext Maybe TLSSettings
mtls Restriction
cfg = 
	Restriction
-> Maybe TLSSettings
-> Maybe ConnectionContext
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getConnection Restriction
cfg (TLSSettings -> Maybe TLSSettings
forall a. a -> Maybe a
Just (TLSSettings -> Maybe TLSSettings -> TLSSettings
forall a. a -> Maybe a -> a
fromMaybe TLSSettings
forall a. Default a => a
def Maybe TLSSettings
mtls)) Maybe ConnectionContext
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 :: Restriction
-> Maybe TLSSettings
-> Maybe ConnectionContext
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getConnection Restriction
cfg Maybe TLSSettings
tls Maybe ConnectionContext
mcontext = do
	ConnectionContext
context <- IO ConnectionContext
-> (ConnectionContext -> IO ConnectionContext)
-> Maybe ConnectionContext
-> IO ConnectionContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext ConnectionContext -> IO ConnectionContext
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
	(Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe HostAddress -> String -> Int -> IO Connection)
 -> IO (Maybe HostAddress -> String -> Int -> IO Connection))
-> (Maybe HostAddress -> String -> Int -> IO Connection)
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
forall a b. (a -> b) -> a -> b
$ \Maybe HostAddress
_ha String
h Int
p -> IO Connection
-> (Connection -> IO ())
-> (Connection -> IO Connection)
-> IO Connection
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
		(ConnectionContext -> String -> Int -> IO Connection
forall a.
(Integral a, Show a) =>
ConnectionContext -> String -> a -> IO Connection
go ConnectionContext
context String
h Int
p)
		Connection -> IO ()
NC.connectionClose
		Connection -> IO Connection
convertConnection
   where
	go :: ConnectionContext -> String -> a -> IO Connection
go ConnectionContext
context String
h a
p = do
		let connparams :: ConnectionParams
connparams = ConnectionParams :: String
-> PortNumber
-> Maybe TLSSettings
-> Maybe SockSettings
-> ConnectionParams
NC.ConnectionParams
			{ connectionHostname :: String
NC.connectionHostname = String
h
			, connectionPort :: PortNumber
NC.connectionPort = a -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p
			, connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = Maybe TLSSettings
tls
			, connectionUseSocks :: Maybe SockSettings
NC.connectionUseSocks = Maybe SockSettings
forall a. Maybe a
Nothing -- unsupprted
			}
		ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
		let serv :: String
serv = a -> String
forall a. Show a => a -> String
show a
p
		let hints :: AddrInfo
hints = AddrInfo
defaultHints
			{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG]
			, addrProtocol :: ProtocolNumber
addrProtocol = ProtocolNumber
proto
			, addrSocketType :: SocketType
addrSocketType = SocketType
Stream
			}
		[AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
h) (String -> Maybe String
forall a. a -> Maybe a
Just String
serv)
		IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Connection) -> IO Connection
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
			([IO Socket] -> IO Socket
forall a. [IO a] -> IO a
firstSuccessful ([IO Socket] -> IO Socket) -> [IO Socket] -> IO Socket
forall a b. (a -> b) -> a -> b
$ (AddrInfo -> IO Socket) -> [AddrInfo] -> [IO Socket]
forall a b. (a -> b) -> [a] -> [b]
map AddrInfo -> IO Socket
tryToConnect [AddrInfo]
addrs)
			Socket -> IO ()
close
			(\Socket
sock -> ConnectionContext -> Socket -> ConnectionParams -> IO Connection
NC.connectFromSocket ConnectionContext
context Socket
sock ConnectionParams
connparams)
	  where
		tryToConnect :: AddrInfo -> IO Socket
tryToConnect AddrInfo
addr = case Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
cfg AddrInfo
addr of
			Maybe ConnectionRestricted
Nothing -> IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
				(Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr))
				Socket -> IO ()
close
				(\Socket
sock -> Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr) IO () -> IO Socket -> IO Socket
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
			Just ConnectionRestricted
r -> ConnectionRestricted -> IO Socket
forall e a. Exception e => e -> IO a
throwIO ConnectionRestricted
r
		firstSuccessful :: [IO a] -> IO a
firstSuccessful [] = HostNotResolved -> IO a
forall e a. Exception e => e -> IO a
throwIO (HostNotResolved -> IO a) -> HostNotResolved -> IO a
forall a b. (a -> b) -> a -> b
$ String -> HostNotResolved
NC.HostNotResolved String
h
		firstSuccessful (IO a
a:[IO a]
as) = IO a
a IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e ::IOException) ->
			case [IO a]
as of
				[] -> IOException -> IO a
forall e a. Exception e => e -> IO a
throwIO IOException
e
				[IO a]
_ -> [IO a] -> IO a
firstSuccessful [IO a]
as

-- Copied from Network.HTTP.Client.TLS, unfortunately not exported.
convertConnection :: NC.Connection -> IO Connection
convertConnection :: Connection -> IO Connection
convertConnection Connection
conn = IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection
    (Connection -> IO ByteString
NC.connectionGetChunk Connection
conn)
    (Connection -> ByteString -> IO ()
NC.connectionPut Connection
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@.
    (Connection -> IO ()
NC.connectionClose Connection
conn IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: SockAddr -> String
showSockAddress a :: SockAddr
a@(SockAddrInet PortNumber
_ HostAddress
_) =
	(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
a
showSockAddress a :: SockAddr
a@(SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
_ HostAddress
_) =
	(Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
a
showSockAddress SockAddr
a = SockAddr -> String
forall a. Show a => a -> String
show SockAddr
a