diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Change log for "tls" +## Version 2.1.10 + +* Supporting the SSLKEYLOGFILE environment variable. + [#499](https://github.com/haskell-tls/hs-tls/pull/499) + ## Version 2.1.9 * Providing ECH(Encrypted Client Hello). See `sharedECHConfigList`, diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -127,6 +127,7 @@ debugPrintSeed, debugVersionForced, debugKeyLogger, + defaultKeyLogger, debugError, debugTraceKey, diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Context.Internal ( diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -499,7 +499,7 @@ sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx - debugError (ctxDebug ctx) $ reason + debugError (ctxDebug ctx) reason E.throwIO (Terminated False reason err) {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -316,7 +316,7 @@ Just (identities, _, choice, _) -> do let zero = cZero choice zeroR <- getStdRandom $ uniformByteString $ B.length zero - obfAgeR <- getStdRandom $ genWord32 + obfAgeR <- getStdRandom genWord32 let genPskId x = do xR <- getStdRandom $ uniformByteString $ B.length x return $ PskIdentity xR obfAgeR @@ -535,10 +535,10 @@ | otherwise -> lookupECHConfigList xs cnfs cnfKemId :: ECHConfig -> KEM_ID -cnfKemId ECHConfig{..} = KEM_ID $ kem_id $ key_config $ contents +cnfKemId ECHConfig{..} = KEM_ID $ kem_id $ key_config contents cnfCipherSuite :: ECHConfig -> [(KDF_ID, AEAD_ID)] -cnfCipherSuite ECHConfig{..} = map conv $ cipher_suites $ key_config $ contents +cnfCipherSuite ECHConfig{..} = map conv $ cipher_suites $ key_config contents where conv HpkeSymmetricCipherSuite{..} = (KDF_ID kdf_id, AEAD_ID aead_id) diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -131,7 +131,7 @@ contextFlush ctx enablePeerRecordLimit ctx ver <- usingState_ ctx getVersion - verifyData <- VerifyData <$> (generateFinished ctx ver role) + verifyData <- VerifyData <$> generateFinished ctx ver role sendPacket12 ctx (Handshake [Finished verifyData]) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs --- a/Network/TLS/Handshake/Server/ClientHello.hs +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -116,7 +116,7 @@ -- Processing encrypted client hello (mClientHello', receivedECH) <- - if chosenVersion == TLS13 && (not (null (serverECHKey sparams))) + if chosenVersion == TLS13 && not (null (serverECHKey sparams)) then do lookupAndDecodeAndDo EID_EncryptedClientHello diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -179,7 +179,7 @@ let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13 shExts = keyShareExt : versionExt : preSharedKeyExt - if isJust $ mOuterClientRandom + if isJust mOuterClientRandom then do srand <- liftIO $ serverRandomECH ctx let cipherId = CipherId (cipherID usedCipher) diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -8,6 +8,7 @@ CommonParams, DebugParams (..), defaultDebugParams, + defaultKeyLogger, ClientHooks (..), defaultClientHooks, OnCertificateRequest, @@ -30,8 +31,11 @@ Information (..), ) where +import Control.Concurrent (MVar, newMVar, withMVar) import Crypto.HPKE import Data.Default (Default (def)) +import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) import Network.TLS.Cipher import Network.TLS.Compression @@ -77,6 +81,20 @@ , debugTraceKey :: String -> IO () } +{-# NOINLINE keyLogLock #-} +keyLogLock :: MVar () +keyLogLock = unsafePerformIO $ newMVar () + +{-# NOINLINE keyLogFile #-} +keyLogFile :: Maybe FilePath +keyLogFile = unsafePerformIO $ lookupEnv "SSLKEYLOGFILE" + +-- | Key logger with the SSLKEYLOGFILE environment variable. +defaultKeyLogger :: String -> IO () +defaultKeyLogger ~msg = case keyLogFile of + Nothing -> return () + Just file -> withMVar keyLogLock $ \_ -> appendFile file (msg ++ "\n") + -- | Default value for 'DebugParams' defaultDebugParams :: DebugParams defaultDebugParams = @@ -84,7 +102,7 @@ { debugSeed = Nothing , debugPrintSeed = const (return ()) , debugVersionForced = Nothing - , debugKeyLogger = \ ~_ -> return () + , debugKeyLogger = defaultKeyLogger , debugError = \ ~_ -> return () , debugTraceKey = \ ~_ -> return () } diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} -- | The Struct module contains all definitions and values of the TLS diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls -version: 2.1.9 +version: 2.1.10 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -62,9 +62,7 @@ mparams -> return mparams readGroups :: String -> [Group] -readGroups s = case traverse (`lookup` namedGroups) (split ',' s) of - Nothing -> [] - Just gs -> gs +readGroups s = fromMaybe [] $ traverse (`lookup` namedGroups) (split ',' s) printDHParams :: IO () printDHParams = do diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -398,9 +398,7 @@ shared = defaultShared { sharedSessionManager = sm - , sharedCAStore = case mstore of - Just store -> store - Nothing -> mempty + , sharedCAStore = fromMaybe mempty mstore , sharedValidationCache = validateCache , sharedLimit = defaultLimit