{-# 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
data Restriction = Restriction
{ Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
}
addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
addressRestriction AddrInfo -> Maybe ConnectionRestricted
f = 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
{ checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction = \AddrInfo
addr ->
Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
a AddrInfo
addr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
b AddrInfo
addr
}
instance Monoid Restriction where
mempty :: Restriction
mempty = Restriction
{ checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction = \AddrInfo
_ -> forall a. Maybe a
Nothing
}
instance Sem.Semigroup Restriction where
<> :: Restriction -> Restriction -> Restriction
(<>) = Restriction -> Restriction -> Restriction
appendRestrictions
data ConnectionRestricted = ConnectionRestricted String
deriving (Int -> ConnectionRestricted -> ShowS
[ConnectionRestricted] -> ShowS
ConnectionRestricted -> String
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
type IPAddrString = String
connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted
connectionRestricted :: ShowS -> AddrInfo -> ConnectionRestricted
connectionRestricted ShowS
mkmessage =
String -> ConnectionRestricted
ConnectionRestricted forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkmessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. SockAddr -> String
showSockAddress forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrInfo -> SockAddr
addrAddress
data ProxyRestricted = ProxyRestricted
deriving (Int -> ProxyRestricted -> ShowS
[ProxyRestricted] -> ShowS
ProxyRestricted -> String
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)
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 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 = forall a. ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions ManagerSettings
base
}
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 forall a b. (a -> b) -> a -> b
$
Maybe ConnectionContext
-> TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettingsContext Maybe ConnectionContext
mcontext (forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe TLSSettings
mtls) 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 forall a b. (a -> b) -> a -> b
$
ProxyOverride -> ManagerSettings -> ManagerSettings
managerSetSecureProxy ProxyOverride
https_proxy ManagerSettings
base
forall (m :: * -> *) a. Monad m => a -> m a
return (ManagerSettings
ms, Maybe ProxyRestricted
http_r forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ProxyRestricted
https_r)
where
testnetip :: String
testnetip = String
"198.51.100.1"
dummyreq :: Bool -> Request
dummyreq Bool
https = String -> Request
parseRequest_ forall a b. (a -> b) -> a -> b
$
String
"http" forall a. [a] -> [a] -> [a]
++ (if Bool
https then String
"s" else String
"") forall a. [a] -> [a] -> [a]
++ String
"://" forall a. [a] -> [a] -> [a]
++ String
testnetip
getproxyaddr :: Bool -> IO (Maybe AddrInfo)
getproxyaddr Bool
https = IO (Maybe Proxy)
extractproxy forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Proxy
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Proxy
p -> do
ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
let serv :: String
serv = 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 forall a b. (a -> b) -> a -> b
$ Proxy -> ByteString
proxyHost Proxy
p
Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
h) (forall a. a -> Maybe a
Just String
serv) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(AddrInfo
addr:[AddrInfo]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just AddrInfo
addr
where
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request -> Maybe Proxy
proxy forall a b. (a -> b) -> a -> b
$ Request -> Request
f forall a b. (a -> b) -> a -> b
$ Bool -> Request
dummyreq Bool
https
mkproxy :: Maybe AddrInfo -> (ProxyOverride, Maybe ProxyRestricted)
mkproxy Maybe AddrInfo
Nothing = (ProxyOverride
noProxy, 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), forall a. Maybe a
Nothing)
Just ConnectionRestricted
_ -> (ProxyOverride
noProxy, forall a. a -> Maybe a
Just ProxyRestricted
ProxyRestricted)
addrtoproxy :: SockAddr -> ProxyOverride
addrtoproxy SockAddr
addr = case SockAddr
addr of
SockAddrInet PortNumber
pn HostAddress
_ -> forall {a}. Integral a => a -> ProxyOverride
mk PortNumber
pn
SockAddrInet6 PortNumber
pn HostAddress
_ HostAddress6
_ HostAddress
_ -> forall {a}. Integral a => a -> ProxyOverride
mk PortNumber
pn
SockAddr
_ -> ProxyOverride
noProxy
where
mk :: a -> ProxyOverride
mk a
pn = Proxy -> ProxyOverride
useProxy Network.HTTP.Client.Proxy
{ proxyHost :: ByteString
proxyHost = String -> ByteString
BU.fromString (SockAddr -> String
showSockAddress SockAddr
addr)
, proxyPort :: Int
proxyPort = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
pn
}
wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions :: forall a. ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions ManagerSettings
base Request
req IO a
a =
let wrapper :: SomeException -> SomeException
wrapper SomeException
se
| Just (ConnectionRestricted
_ :: ConnectionRestricted) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se =
forall e. Exception e => e -> SomeException
toException forall a b. (a -> b) -> a -> b
$ Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req forall a b. (a -> b) -> a -> b
$
SomeException -> HttpExceptionContent
InternalException SomeException
se
| Bool
otherwise = SomeException
se
in ManagerSettings -> forall a. Request -> IO a -> IO a
managerWrapException ManagerSettings
base Request
req (forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (forall e a. Exception e => e -> IO a
throwIO 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 forall a. Maybe a
Nothing 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 (forall a. a -> Maybe a
Just (forall a. a -> Maybe a -> a
fromMaybe forall a. Default a => a
def Maybe TLSSettings
mtls)) Maybe ConnectionContext
mcontext
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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ConnectionContext
NC.initConnectionContext forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ConnectionContext
mcontext
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Maybe HostAddress
_ha String
h Int
p -> forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(forall {p}.
(Integral p, Show p) =>
ConnectionContext -> String -> p -> IO Connection
go ConnectionContext
context String
h Int
p)
Connection -> IO ()
NC.connectionClose
Connection -> IO Connection
convertConnection
where
go :: ConnectionContext -> String -> p -> IO Connection
go ConnectionContext
context String
h p
p = do
let connparams :: ConnectionParams
connparams = NC.ConnectionParams
{ connectionHostname :: String
NC.connectionHostname = String
hstripped
, connectionPort :: PortNumber
NC.connectionPort = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
p
, connectionUseSecure :: Maybe TLSSettings
NC.connectionUseSecure = Maybe TLSSettings
tls
, connectionUseSocks :: Maybe SockSettings
NC.connectionUseSocks = forall a. Maybe a
Nothing
}
ProtocolNumber
proto <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
let serv :: String
serv = forall a. Show a => a -> String
show p
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 (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
hstripped) (forall a. a -> Maybe a
Just String
serv)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
(forall {a}. [IO a] -> IO a
firstSuccessful forall a b. (a -> b) -> a -> b
$ 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
hstripped :: String
hstripped = ShowS
strippedHostName String
h
tryToConnect :: AddrInfo -> IO Socket
tryToConnect AddrInfo
addr = case Restriction -> AddrInfo -> Maybe ConnectionRestricted
checkAddressRestriction Restriction
cfg AddrInfo
addr of
Maybe ConnectionRestricted
Nothing -> 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock)
Just ConnectionRestricted
r -> forall e a. Exception e => e -> IO a
throwIO ConnectionRestricted
r
firstSuccessful :: [IO a] -> IO a
firstSuccessful [] = forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> HostNotResolved
NC.HostNotResolved String
hstripped
firstSuccessful (IO a
a:[IO a]
as) = IO a
a forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e ::IOException) ->
case [IO a]
as of
[] -> forall e a. Exception e => e -> IO a
throwIO IOException
e
[IO a]
_ -> [IO a] -> IO a
firstSuccessful [IO a]
as
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)
(Connection -> IO ()
NC.connectionClose Connection
conn forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Control.Exception.catch` \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
showSockAddress :: SockAddr -> IPAddrString
showSockAddress :: SockAddr -> String
showSockAddress a :: SockAddr
a@(SockAddrInet PortNumber
_ HostAddress
_) =
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
':') forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SockAddr
a
showSockAddress a :: SockAddr
a@(SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
_ HostAddress
_) =
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
']') forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SockAddr
a
showSockAddress SockAddr
a = forall a. Show a => a -> String
show SockAddr
a