diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.3.2.0 + +* http-client-openssl: added reasonable OpenSSL default settings + ## 0.3.1.0 * Fix a bug with http-proxy that would cause SNI to be set incorrectly; (would use the domain of the proxy, instead of the server we're trying to reach diff --git a/Network/HTTP/Client/OpenSSL.hs b/Network/HTTP/Client/OpenSSL.hs --- a/Network/HTTP/Client/OpenSSL.hs +++ b/Network/HTTP/Client/OpenSSL.hs @@ -1,83 +1,55 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} -- | Support for making connections via the OpenSSL library. module Network.HTTP.Client.OpenSSL - ( opensslManagerSettings - -- , defaultMakeContext - , withOpenSSL + ( 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.Session as SSL +import qualified OpenSSL.X509.SystemStore as SSL (contextLoadSystemCerts) --- | Note that it is the caller's responsibility to pass in an appropriate --- context. Future versions of http-client-openssl will hopefully include a --- sane, safe default. +-- | Create a new 'Manager' using 'opensslManagerSettings' and 'defaultMakeContext' +-- with 'defaultOpenSSLSettings'. +newOpenSSLManager :: MonadIO m => m Manager +newOpenSSLManager = liftIO $ do + -- sharing an SSL context between threads (without modifying it) is safe: + -- https://github.com/openssl/openssl/issues/2165 + ctx <- defaultMakeContext defaultOpenSSLSettings + newManager $ opensslManagerSettings (pure ctx) + +-- | Note that it is the caller's responsibility to pass in an appropriate context. opensslManagerSettings :: IO SSL.SSLContext -> ManagerSettings opensslManagerSettings mkContext = defaultManagerSettings { managerTlsConnection = do ctx <- mkContext - return $ \_ha host' port' -> do - -- Copied/modified from openssl-streams - let hints = N.defaultHints - { N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] - , N.addrFamily = N.AF_INET - , N.addrSocketType = N.Stream - } - (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host') (Just $ show port') - - let family = N.addrFamily addrInfo - let socketType = N.addrSocketType addrInfo - let protocol = N.addrProtocol addrInfo - let address = N.addrAddress addrInfo - - bracketOnError (N.socket family socketType protocol) (N.close) - $ \sock -> do - N.connect sock address - ssl <- SSL.connection ctx sock - SSL.setTlsextHostName ssl host' - SSL.connect ssl - makeConnection - (SSL.read ssl 32752 `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> return S.empty) - (SSL.write ssl) - (N.close sock) + return $ \_ha host' port' -> + withSocket host' port' $ \sock -> + makeSSLConnection ctx sock host' , managerTlsProxyConnection = do ctx <- mkContext - return $ \connstr checkConn serverName _ha host' port' -> do - -- Copied/modified from openssl-streams - let hints = N.defaultHints - { N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] - , N.addrFamily = N.AF_INET - , N.addrSocketType = N.Stream - } - (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host') (Just $ show port') - - let family = N.addrFamily addrInfo - let socketType = N.addrSocketType addrInfo - let protocol = N.addrProtocol addrInfo - let address = N.addrAddress addrInfo - - bracketOnError (N.socket family socketType protocol) (N.close) - $ \sock -> do - N.connect sock address - conn <- makeConnection - (recv sock 32752) - (sendAll sock) - (return ()) - connectionWrite conn connstr - checkConn conn - ssl <- SSL.connection ctx sock - SSL.setTlsextHostName ssl serverName - SSL.connect ssl - makeConnection - (SSL.read ssl 32752 `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> return S.empty) - (SSL.write ssl) - (N.close sock) + return $ \connstr checkConn serverName _ha host' port' -> + withSocket host' port' $ \sock -> do + conn <- makeConnection + (recv sock 32752) + (sendAll sock) + (return ()) + connectionWrite conn connstr + checkConn conn + makeSSLConnection ctx sock serverName , managerRetryableException = \se -> case () of @@ -97,4 +69,73 @@ se' = toException (HttpExceptionRequest req (InternalException se)) in handle (throwIO . wrap) + } + where + withSocket host port use = do + -- Copied/modified from openssl-streams + let hints = N.defaultHints + { N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] + , N.addrFamily = N.AF_INET + , N.addrSocketType = N.Stream + } + + (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host) (Just $ show port) + + let family = N.addrFamily addrInfo + let socketType = N.addrSocketType addrInfo + let protocol = N.addrProtocol addrInfo + let address = N.addrAddress addrInfo + + bracketOnError (N.socket family socketType protocol) (N.close) $ + \sock -> N.connect sock address *> use sock + + makeSSLConnection ctx sock host = do + ssl <- SSL.connection ctx sock + SSL.setTlsextHostName ssl host + SSL.enableHostnameValidation ssl host + SSL.connect ssl + makeConnection + (SSL.read ssl 32752 `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> return S.empty) + (SSL.write ssl) + (N.close sock) + +defaultMakeContext :: OpenSSLSettings -> IO SSL.SSLContext +defaultMakeContext OpenSSLSettings{..} = do + ctx <- SSL.context + SSL.contextSetVerificationMode ctx osslSettingsVerifyMode + SSL.contextSetCiphers ctx osslSettingsCiphers + mapM_ (SSL.contextAddOption ctx) osslSettingsOptions + osslSettingsLoadCerts ctx + return ctx + +data OpenSSLSettings = OpenSSLSettings + { osslSettingsOptions :: [SSL.SSLOption] + , osslSettingsVerifyMode :: SSL.VerificationMode + , osslSettingsCiphers :: String + , osslSettingsLoadCerts :: SSL.SSLContext -> IO () + } + +-- | Default OpenSSL settings. In particular: +-- +-- * SSLv2 and SSLv3 are disabled +-- * Hostname validation +-- * @DEFAULT@ cipher list +-- * Certificates loaded from OS-specific store +-- +-- Note that these settings might change in the future. +defaultOpenSSLSettings :: OpenSSLSettings +defaultOpenSSLSettings = OpenSSLSettings + { osslSettingsOptions = + [ SSL.SSL_OP_ALL -- enable bug workarounds + , SSL.SSL_OP_NO_SSLv2 + , SSL.SSL_OP_NO_SSLv3 + ] + , osslSettingsVerifyMode = SSL.VerifyPeer + -- vpFailIfNoPeerCert and vpClientOnce are only relevant for servers + { SSL.vpFailIfNoPeerCert = False + , SSL.vpClientOnce = False + , SSL.vpCallback = Nothing + } + , osslSettingsCiphers = "DEFAULT" + , osslSettingsLoadCerts = SSL.contextLoadSystemCerts } diff --git a/http-client-openssl.cabal b/http-client-openssl.cabal --- a/http-client-openssl.cabal +++ b/http-client-openssl.cabal @@ -1,5 +1,5 @@ name: http-client-openssl -version: 0.3.1.0 +version: 0.3.2.0 synopsis: http-client backend using the OpenSSL library. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client @@ -23,7 +23,8 @@ , bytestring , http-client >= 0.2 , network - , HsOpenSSL >= 0.11.2.0 + , HsOpenSSL >= 0.11.4.20 + , HsOpenSSL-x509-system default-language: Haskell2010 test-suite spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,20 +9,20 @@ main :: IO () main = withOpenSSL $ hspec $ do it "make a TLS connection" $ do - manager <- newManager $ opensslManagerSettings SSL.context + manager <- newOpenSSLManager withResponse (parseRequest_ "HEAD https://s3.amazonaws.com/hackage.fpcomplete.com/01-index.tar.gz") manager $ \res -> do responseStatus res `shouldBe` status200 lookup "content-type" (responseHeaders res) `shouldBe` Just "application/x-gzip" #ifdef USE_PROXY it "make a TLS connection with proxy" $ do - manager <- newManager $ opensslManagerSettings SSL.context + manager <- newOpenSSLManager let req = addProxy "localhost" 8080 $ parseRequest_ "HEAD https://s3.amazonaws.com/hackage.fpcomplete.com/01-index.tar.gz" withResponse req manager $ \res -> do responseStatus res `shouldBe` status200 lookup "content-type" (responseHeaders res) `shouldBe` Just "application/x-gzip" it "compare responses without and with proxy" $ do - manager <- newManager $ opensslManagerSettings SSL.context + manager <- newOpenSSLManager let req = parseRequest_ "GET https://raw.githubusercontent.com/snoyberg/http-client/master/README.md" v_org <- withResponse req manager $ \res -> do lbsResponse res @@ -30,3 +30,23 @@ lbsResponse res (responseBody v) `shouldBe` (responseBody v_org) #endif + + it "BadSSL: expired" $ do + manager <- newOpenSSLManager + let action = withResponse "https://expired.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: self-signed" $ do + manager <- newOpenSSLManager + let action = withResponse "https://self-signed.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: wrong.host" $ do + manager <- newOpenSSLManager + let action = withResponse "https://wrong.host.badssl.com/" manager (const (return ())) + action `shouldThrow` anyException + + it "BadSSL: we do have case-insensitivity though" $ do + manager <- newOpenSSLManager + withResponse "https://BADSSL.COM" manager $ \res -> + responseStatus res `shouldBe` status200