{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-}
{-# LANGUAGE CPP #-}
module Network.HTTP.Client.Restricted (
Restriction,
addressRestriction,
mkRestrictedManagerSettings,
ConnectionRestricted(..),
connectionRestricted,
ProxyRestricted(..),
IPAddrString,
) where
import Network.HTTP.Client
import Network.HTTP.Client.Internal
(ManagerSettings(..), Connection, runProxyOverride, makeConnection)
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
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Sem
#endif
import Data.Monoid
import Control.Applicative
import Prelude
data Restriction = Restriction
{ _addressRestriction :: AddrInfo -> Maybe ConnectionRestricted
}
addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction
addressRestriction f = mempty { _addressRestriction = f }
appendRestrictions :: Restriction -> Restriction -> Restriction
appendRestrictions a b = Restriction
{ _addressRestriction = \addr ->
_addressRestriction a addr <|> _addressRestriction b addr
}
instance Monoid Restriction where
mempty = Restriction
{ _addressRestriction = \_ -> Nothing
}
#if MIN_VERSION_base(4,11,0)
#elif MIN_VERSION_base(4,9,0)
mappend = (Sem.<>)
#else
mappend = appendRestrictions
#endif
#if MIN_VERSION_base(4,9,0)
instance Sem.Semigroup Restriction where
(<>) = appendRestrictions
#endif
data ConnectionRestricted = ConnectionRestricted String
deriving (Show, Typeable)
instance Exception ConnectionRestricted
type IPAddrString = String
connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted
connectionRestricted mkmessage =
ConnectionRestricted . mkmessage . showSockAddress . addrAddress
data ProxyRestricted = ProxyRestricted
deriving (Show)
restrictManagerSettings
:: Maybe NC.ConnectionContext
-> Maybe NC.TLSSettings
-> Restriction
-> ManagerSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
restrictManagerSettings mcontext mtls cfg base = restrictProxy cfg $ base
{ managerRawConnection = restrictedRawConnection cfg
, managerTlsConnection = restrictedTlsConnection mcontext mtls cfg
#if MIN_VERSION_http_client(0,5,0)
, managerWrapException = wrapOurExceptions base
#else
, managerWrapIOException = wrapOurExceptions base
#endif
}
mkRestrictedManagerSettings
:: Restriction
-> Maybe NC.ConnectionContext
-> Maybe NC.TLSSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
mkRestrictedManagerSettings cfg mcontext mtls =
restrictManagerSettings mcontext mtls cfg $
mkManagerSettingsContext mcontext (fromMaybe def mtls) Nothing
restrictProxy
:: Restriction
-> ManagerSettings
-> IO (ManagerSettings, Maybe ProxyRestricted)
restrictProxy cfg base = do
http_proxy_addr <- getproxyaddr False
https_proxy_addr <- getproxyaddr True
let (http_proxy, http_r) = mkproxy http_proxy_addr
let (https_proxy, https_r) = mkproxy https_proxy_addr
let ms = managerSetInsecureProxy http_proxy $
managerSetSecureProxy https_proxy base
return (ms, http_r <|> https_r)
where
testnetip = "198.51.100.1"
dummyreq https = parseRequest_ $
"http" ++ (if https then "s" else "") ++ "://" ++ testnetip
getproxyaddr https = extractproxy >>= \case
Nothing -> return Nothing
Just p -> do
proto <- getProtocolNumber "tcp"
let serv = show (proxyPort p)
let hints = defaultHints
{ addrFlags = [AI_ADDRCONFIG]
, addrProtocol = proto
, addrSocketType = Stream
}
let h = BU.toString $ proxyHost p
getAddrInfo (Just hints) (Just h) (Just serv) >>= \case
[] -> return Nothing
(addr:_) -> return $ Just addr
where
extractproxy = do
let po = if https
then managerProxySecure base
else managerProxyInsecure base
f <- runProxyOverride po https
return $ proxy $ f $ dummyreq https
mkproxy Nothing = (noProxy, Nothing)
mkproxy (Just proxyaddr) = case _addressRestriction cfg proxyaddr of
Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing)
Just _ -> (noProxy, Just ProxyRestricted)
addrtoproxy addr = case addr of
SockAddrInet pn _ -> mk pn
SockAddrInet6 pn _ _ _ -> mk pn
_ -> noProxy
where
mk pn = useProxy Network.HTTP.Client.Proxy
{ proxyHost = BU.fromString (showSockAddress addr)
, proxyPort = fromIntegral pn
}
#if MIN_VERSION_http_client(0,5,0)
wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a
wrapOurExceptions base req a =
let wrapper se
| Just (_ :: ConnectionRestricted) <- fromException se =
toException $ HttpExceptionRequest req $
InternalException se
| otherwise = se
in managerWrapException base req (handle (throwIO . wrapper) a)
#else
wrapOurExceptions :: ManagerSettings -> IO a -> IO a
wrapOurExceptions base a =
let wrapper se = case fromException se of
Just (_ :: ConnectionRestricted) ->
toException $ TlsException se
Nothing -> se
in managerWrapIOException base (handle (throwIO . wrapper) a)
#endif
restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedRawConnection cfg = getConnection cfg Nothing Nothing
restrictedTlsConnection :: Maybe NC.ConnectionContext -> Maybe NC.TLSSettings -> Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)
restrictedTlsConnection mcontext mtls cfg =
getConnection cfg (Just (fromMaybe def mtls)) mcontext
getConnection
:: Restriction
-> Maybe NC.TLSSettings
-> Maybe NC.ConnectionContext
-> IO (Maybe HostAddress -> String -> Int -> IO Connection)
getConnection cfg tls mcontext = do
context <- maybe NC.initConnectionContext return mcontext
return $ \_ha h p -> bracketOnError
(go context h p)
NC.connectionClose
convertConnection
where
go context h p = do
let connparams = NC.ConnectionParams
{ NC.connectionHostname = h
, NC.connectionPort = fromIntegral p
, NC.connectionUseSecure = tls
, NC.connectionUseSocks = Nothing
}
proto <- getProtocolNumber "tcp"
let serv = show p
let hints = defaultHints
{ addrFlags = [AI_ADDRCONFIG]
, addrProtocol = proto
, addrSocketType = Stream
}
addrs <- getAddrInfo (Just hints) (Just h) (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 h
firstSuccessful (a:as) = a `catch` \(e ::IOException) ->
case as of
[] -> throwIO e
_ -> firstSuccessful as
convertConnection :: NC.Connection -> IO Connection
convertConnection conn = makeConnection
(NC.connectionGetChunk conn)
(NC.connectionPut conn)
(NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ())
showSockAddress :: SockAddr -> IPAddrString
showSockAddress a@(SockAddrInet _ _) =
takeWhile (/= ':') $ show a
showSockAddress a@(SockAddrInet6 _ _ _ _) =
takeWhile (/= ']') $ drop 1 $ show a
showSockAddress a = show a