{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.HTTP.Client.OpenSSL
(
newOpenSSLManager
, opensslManagerSettings
, defaultMakeContext
, OpenSSLSettings(..)
, defaultOpenSSLSettings
, OpenSSL.withOpenSSL
) 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 qualified Data.ByteString as S
import qualified Network.Socket as N
import qualified OpenSSL
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 = IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ do
SSLContext
ctx <- OpenSSLSettings -> IO SSLContext
defaultMakeContext OpenSSLSettings
defaultOpenSSLSettings
ManagerSettings -> IO Manager
newManager (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$ IO SSLContext -> ManagerSettings
opensslManagerSettings (SSLContext -> IO SSLContext
forall a. a -> IO a
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 = do
ctx <- mkContext
return $ \Maybe HostAddress
ha' String
host' Int
port' ->
(Socket -> IO ())
-> Maybe HostAddress
-> String
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket (IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe HostAddress
ha' String
host' Int
port' ((Socket -> IO Connection) -> IO Connection)
-> (Socket -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \Socket
sock ->
SSLContext -> Socket -> String -> IO Connection
makeSSLConnection SSLContext
ctx Socket
sock String
host'
, managerTlsProxyConnection = do
ctx <- mkContext
return $ \ByteString
connstr Connection -> IO ()
checkConn String
serverName Maybe HostAddress
_ha String
host' Int
port' ->
(Socket -> IO ())
-> Maybe HostAddress
-> String
-> Int
-> (Socket -> IO Connection)
-> IO Connection
forall a.
(Socket -> IO ())
-> Maybe HostAddress -> String -> Int -> (Socket -> IO a) -> IO a
withSocket (IO () -> Socket -> IO ()
forall a b. a -> b -> a
const (IO () -> Socket -> IO ()) -> IO () -> Socket -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe HostAddress
forall a. Maybe a
Nothing String
host' Int
port' ((Socket -> IO Connection) -> IO Connection)
-> (Socket -> IO Connection) -> IO Connection
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
Connection
conn <- IO ByteString
-> (ByteString -> IO ()) -> IO () -> Socket -> IO Connection
forall a.
Typeable a =>
IO ByteString
-> (ByteString -> IO ()) -> IO () -> a -> IO Connection
makeConnection
(Socket -> Int -> IO ByteString
recv Socket
sock Int
bufSize)
(Socket -> ByteString -> IO ()
sendAll Socket
sock)
(() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
Socket
sock
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
se ->
case () of
()
| Just (ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) <- SomeException -> Maybe ConnectionAbruptlyTerminated
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se -> Bool
True
| Bool
otherwise -> ManagerSettings -> SomeException -> Bool
managerRetryableException ManagerSettings
defaultManagerSettings SomeException
se
, managerWrapException = \Request
req ->
let
wrap :: SomeException -> SomeException
wrap SomeException
se
| Just (IOException
_ :: IOException) <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (SomeSSLException
_ :: SSL.SomeSSLException) <- SomeException -> Maybe SomeSSLException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) <- SomeException -> Maybe ConnectionAbruptlyTerminated
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Just (ProtocolError
_ :: SSL.ProtocolError) <- SomeException -> Maybe ProtocolError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
se = SomeException
se'
| Bool
otherwise = SomeException
se
where
se' :: SomeException
se' = HttpException -> SomeException
forall e. Exception e => e -> SomeException
toException (Request -> HttpExceptionContent -> HttpException
HttpExceptionRequest Request
req (SomeException -> HttpExceptionContent
InternalException SomeException
se))
in
(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
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 -> String
strippedHostName String
host)
SSL -> String -> IO ()
SSL.enableHostnameValidation SSL
ssl (String -> String
strippedHostName String
host)
SSL -> IO ()
SSL.connect SSL
ssl
IO ByteString
-> (ByteString -> IO ()) -> IO () -> SSL -> IO Connection
forall a.
Typeable a =>
IO ByteString
-> (ByteString -> IO ()) -> IO () -> a -> IO Connection
makeConnection
(SSL -> Int -> IO ByteString
SSL.read SSL
ssl Int
bufSize IO ByteString
-> (ConnectionAbruptlyTerminated -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(ConnectionAbruptlyTerminated
_ :: SSL.ConnectionAbruptlyTerminated) -> ByteString -> IO ByteString
forall a. a -> IO a
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)
SSL
ssl
bufSize :: Int
bufSize :: Int
bufSize = Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
overhead
where overhead :: Int
overhead = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Storable a => a -> Int
sizeOf (Int
forall a. HasCallStack => a
undefined :: Int)
defaultMakeContext :: OpenSSLSettings -> IO SSL.SSLContext
defaultMakeContext :: OpenSSLSettings -> IO SSLContext
defaultMakeContext OpenSSLSettings{String
[SSLOption]
VerificationMode
SSLContext -> IO ()
osslSettingsOptions :: [SSLOption]
osslSettingsVerifyMode :: VerificationMode
osslSettingsCiphers :: String
osslSettingsLoadCerts :: SSLContext -> IO ()
osslSettingsOptions :: OpenSSLSettings -> [SSLOption]
osslSettingsVerifyMode :: OpenSSLSettings -> VerificationMode
osslSettingsCiphers :: OpenSSLSettings -> String
osslSettingsLoadCerts :: OpenSSLSettings -> SSLContext -> IO ()
..} = 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
(SSLOption -> IO ()) -> [SSLOption] -> IO ()
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
SSLContext -> IO SSLContext
forall a. a -> IO a
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 = Maybe (Bool -> X509StoreCtx -> IO Bool)
forall a. Maybe a
Nothing
}
, osslSettingsCiphers :: String
osslSettingsCiphers = String
"DEFAULT"
, osslSettingsLoadCerts :: SSLContext -> IO ()
osslSettingsLoadCerts = SSLContext -> IO ()
SSL.contextLoadSystemCerts
}