{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Network.HTTP.Client.OpenSSL
( withOpenSSL
, newOpenSSLManager
, opensslManagerSettings
, defaultMakeContext
, OpenSSLSettings(..)
, defaultOpenSSLSettings
) where
import Network.HTTP.Client
import Network.HTTP.Client.Internal
import Control.Exception
import Control.Monad.IO.Class
import Network.Socket.ByteString (sendAll, recv)
import OpenSSL
import qualified Data.ByteString as S
import qualified Network.Socket as N
import qualified OpenSSL.Session as SSL
import qualified OpenSSL.X509.SystemStore as SSL (contextLoadSystemCerts)
import Foreign.Storable (sizeOf)
newOpenSSLManager :: MonadIO m => m Manager
newOpenSSLManager :: forall (m :: * -> *). MonadIO m => m Manager
newOpenSSLManager = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
SSLContext
ctx <- OpenSSLSettings -> IO SSLContext
defaultMakeContext OpenSSLSettings
defaultOpenSSLSettings
ManagerSettings -> IO Manager
newManager forall a b. (a -> b) -> a -> b
$ IO SSLContext -> ManagerSettings
opensslManagerSettings (forall (f :: * -> *) a. Applicative f => a -> f a
pure SSLContext
ctx)
opensslManagerSettings :: IO SSL.SSLContext -> ManagerSettings
opensslManagerSettings :: IO SSLContext -> ManagerSettings
opensslManagerSettings IO SSLContext
mkContext = ManagerSettings
defaultManagerSettings
{ managerTlsConnection :: IO (Maybe HostAddress -> String -> Int -> IO Connection)
managerTlsConnection = do
SSLContext
ctx <- IO SSLContext
mkContext
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Maybe HostAddress
ha' String
host' Int
port' ->
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe HostAddress
ha' String
host' Int
port' forall a b. (a -> b) -> a -> b
$ \Socket
sock ->
SSLContext -> Socket -> String -> IO Connection
makeSSLConnection SSLContext
ctx Socket
sock String
host'
, managerTlsProxyConnection :: IO
(ByteString
-> (Connection -> IO ())
-> String
-> Maybe HostAddress
-> String
-> Int
-> IO Connection)
managerTlsProxyConnection = do
SSLContext
ctx <- IO SSLContext
mkContext
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ByteString
connstr Connection -> IO ()
checkConn String
serverName Maybe HostAddress
_ha String
host' Int
port' ->
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a. Maybe a
Nothing String
host' Int
port' forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
Connection
conn <- IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection
(Socket -> Int -> IO ByteString
recv Socket
sock Int
bufSize)
(Socket -> ByteString -> IO ()
sendAll Socket
sock)
(forall (m :: * -> *) a. Monad m => a -> m a
return ())
Connection -> ByteString -> IO ()
connectionWrite Connection
conn ByteString
connstr
Connection -> IO ()
checkConn Connection
conn
SSLContext -> Socket -> String -> IO Connection
makeSSLConnection SSLContext
ctx Socket
sock String
serverName
, managerRetryableException :: SomeException -> Bool
managerRetryableException = \SomeException
se ->
case () of
()
| Just (ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se -> Bool
True
| Bool
otherwise -> ManagerSettings -> SomeException -> Bool
managerRetryableException ManagerSettings
defaultManagerSettings SomeException
se
, managerWrapException :: forall a. Request -> IO a -> IO a
managerWrapException = \Request
req ->
let
wrap :: SomeException -> SomeException
wrap SomeException
se
| Just (IOException
_ :: IOException) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (SomeSSLException
_ :: SSL.SomeSSLException) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (ProtocolError
_ :: SSL.ProtocolError) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Bool
otherwise = SomeException
se
where
se' :: SomeException
se' = forall e. Exception e => e -> SomeException
toException (Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req (SomeException -> HttpExceptionContent
InternalException SomeException
se))
in
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
wrap)
}
where
makeSSLConnection :: SSLContext -> Socket -> String -> IO Connection
makeSSLConnection SSLContext
ctx Socket
sock String
host = do
SSL
ssl <- SSLContext -> Socket -> IO SSL
SSL.connection SSLContext
ctx Socket
sock
SSL -> String -> IO ()
SSL.setTlsextHostName SSL
ssl String
host
SSL -> String -> IO ()
SSL.enableHostnameValidation SSL
ssl String
host
SSL -> IO ()
SSL.connect SSL
ssl
IO ByteString -> (ByteString -> IO ()) -> IO () -> IO Connection
makeConnection
(SSL -> Int -> IO ByteString
SSL.read SSL
ssl Int
bufSize forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
S.empty)
(SSL -> ByteString -> IO ()
SSL.write SSL
ssl)
(Socket -> IO ()
N.close Socket
sock)
bufSize :: Int
bufSize :: Int
bufSize = Int
32 forall a. Num a => a -> a -> a
* Int
1024 forall a. Num a => a -> a -> a
- Int
overhead
where overhead :: Int
overhead = Int
2 forall a. Num a => a -> a -> a
* forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Int)
defaultMakeContext :: OpenSSLSettings -> IO SSL.SSLContext
defaultMakeContext :: OpenSSLSettings -> IO SSLContext
defaultMakeContext OpenSSLSettings{String
[SSLOption]
VerificationMode
SSLContext -> IO ()
osslSettingsLoadCerts :: OpenSSLSettings -> SSLContext -> IO ()
osslSettingsCiphers :: OpenSSLSettings -> String
osslSettingsVerifyMode :: OpenSSLSettings -> VerificationMode
osslSettingsOptions :: OpenSSLSettings -> [SSLOption]
osslSettingsLoadCerts :: SSLContext -> IO ()
osslSettingsCiphers :: String
osslSettingsVerifyMode :: VerificationMode
osslSettingsOptions :: [SSLOption]
..} = do
SSLContext
ctx <- IO SSLContext
SSL.context
SSLContext -> VerificationMode -> IO ()
SSL.contextSetVerificationMode SSLContext
ctx VerificationMode
osslSettingsVerifyMode
SSLContext -> String -> IO ()
SSL.contextSetCiphers SSLContext
ctx String
osslSettingsCiphers
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SSLContext -> SSLOption -> IO ()
SSL.contextAddOption SSLContext
ctx) [SSLOption]
osslSettingsOptions
SSLContext -> IO ()
osslSettingsLoadCerts SSLContext
ctx
forall (m :: * -> *) a. Monad m => a -> m a
return SSLContext
ctx
data OpenSSLSettings = OpenSSLSettings
{ OpenSSLSettings -> [SSLOption]
osslSettingsOptions :: [SSL.SSLOption]
, OpenSSLSettings -> VerificationMode
osslSettingsVerifyMode :: SSL.VerificationMode
, OpenSSLSettings -> String
osslSettingsCiphers :: String
, OpenSSLSettings -> SSLContext -> IO ()
osslSettingsLoadCerts :: SSL.SSLContext -> IO ()
}
defaultOpenSSLSettings :: OpenSSLSettings
defaultOpenSSLSettings :: OpenSSLSettings
defaultOpenSSLSettings = OpenSSLSettings
{ osslSettingsOptions :: [SSLOption]
osslSettingsOptions =
[ SSLOption
SSL.SSL_OP_ALL
, SSLOption
SSL.SSL_OP_NO_SSLv2
, SSLOption
SSL.SSL_OP_NO_SSLv3
]
, osslSettingsVerifyMode :: VerificationMode
osslSettingsVerifyMode = SSL.VerifyPeer
{ vpFailIfNoPeerCert :: Bool
SSL.vpFailIfNoPeerCert = Bool
False
, vpClientOnce :: Bool
SSL.vpClientOnce = Bool
False
, vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool)
SSL.vpCallback = forall a. Maybe a
Nothing
}
, osslSettingsCiphers :: String
osslSettingsCiphers = String
"DEFAULT"
, osslSettingsLoadCerts :: SSLContext -> IO ()
osslSettingsLoadCerts = SSLContext -> IO ()
SSL.contextLoadSystemCerts
}