Merge PR haskell-tls#317.

core/Network/TLS/Context.hs

@@ -168,6 +168,7 @@ contextNew backend params = liftIO $ do
             , ctxLockRead         = lockRead
             , ctxLockState        = lockState
             , ctxPendingActions   = as
+            , ctxKeyLogger        = debugKeyLogger debug
             }
 
 -- | create a new context on an handle.

core/Network/TLS/Context/Internal.hs

@@ -117,6 +117,7 @@ data Context = Context
     , ctxLockState        :: MVar ()       -- ^ lock used during read/write when receiving and sending packet.
                                            -- it is usually nested in a write or read lock.
     , ctxPendingActions   :: MVar [PendingAction]
+    , ctxKeyLogger        :: String -> IO ()
     }
 
 data Established = NotEstablished

core/Network/TLS/Handshake/Client.hs

@@ -73,10 +73,6 @@ handshakeClient cparams ctx = do
 -- So, the ClientRandom in the first client hello is necessary.
 handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO ()
 handshakeClient' cparams ctx groups mcrand = do
-    -- putStr $ "groups = " ++ show groups ++ ", keyshare = ["
-    -- case groups of
-    --     []  -> putStrLn "]"
-    --     g:_ -> putStrLn $ show g ++ "]"
     updateMeasure ctx incrementNbHandshakes
     sentExtensions <- sendClientHello mcrand
     recvServerHello sentExtensions
@@ -264,9 +260,7 @@ handshakeClient' cparams ctx groups mcrand = do
                 let hCh = hash usedHash $ B.concat hmsgs -- fixme
                 EarlySecret earlySecret <- usingHState ctx getTLS13Secret -- fixme
                 let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh
-                -- putStrLn $ "hCh: " ++ showBytesHex hCh
-                -- dumpKey ctx "CLIENT_EARLY_TRAFFIC_SECRET" clientEarlyTrafficSecret
-                -- putStrLn "---- setTxState ctx usedHash usedCipher clientEarlyTrafficSecret"
+                logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)
                 setTxState ctx usedHash usedCipher clientEarlyTrafficSecret
                 mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData
                 usingHState ctx $ setTLS13RTT0Status RTT0Sent
@@ -460,7 +454,8 @@ sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertifi
                     (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46
 
                     let premaster = encodePreMasterSecret clientVersion prerand
-                    usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
+                    masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
+                    logKey ctx (MasterSecret masterSecret)
                     encryptedPreMaster <- do
                         -- SSL3 implementation generally forget this length field since it's redundant,
                         -- however TLS10 make it clear that the length field need to be present.
@@ -504,8 +499,8 @@ sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertifi
                                      Nothing   -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)
                                      Just pair -> return pair
 
-                    usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
-
+                    masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
+                    logKey ctx (MasterSecret masterSecret)
                     return $ CKX_DH clientDHPub
 
                 getCKX_ECDHE = do
@@ -516,7 +511,8 @@ sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertifi
                         Nothing                  -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)
                         Just (clipub, premaster) -> do
                             xver <- usingState_ ctx getVersion
-                            usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
+                            masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
+                            logKey ctx (MasterSecret masterSecret)
                             return $ CKX_ECDH $ encodeGroupPublic clipub
 
         -- In order to send a proper certificate verify message,
@@ -625,7 +621,9 @@ onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cip
         case resumingSession of
             Nothing          -> return $ RecvStateHandshake (processCertificate cparams ctx)
             Just sessionData -> do
-                usingHState ctx (setMasterSecret rver ClientRole $ sessionSecret sessionData)
+                let masterSecret = sessionSecret sessionData
+                usingHState ctx $ setMasterSecret rver ClientRole masterSecret
+                logKey ctx (MasterSecret masterSecret)
                 return $ RecvStateNext expectChangeCipher
 onServerHello _ _ _ p = unexpected (show p) (Just "server hello")
 
@@ -773,7 +771,6 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
         return accepted
     hChSf <- transcriptHash ctx
     when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])
-    -- putStrLn "---- setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret"
     setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret
     chain <- clientChain cparams ctx
     runPacketFlight ctx $ do
@@ -816,12 +813,8 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
         hChSh <- transcriptHash ctx
         let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh
             serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh
-        -- putStrLn $ "earlySecret: " ++ showBytesHex earlySecret
-        -- putStrLn $ "handshakeSecret: " ++ showBytesHex handshakeSecret
-        -- putStrLn $ "hChSh: " ++ showBytesHex hChSh
-        -- usingHState ctx getHandshakeMessages >>= mapM_ (putStrLn . showBytesHex)
-        -- dumpKey ctx "SERVER_HANDSHAKE_TRAFFIC_SECRET" serverHandshakeTrafficSecret
-        -- dumpKey ctx "CLIENT_HANDSHAKE_TRAFFIC_SECRET" clientHandshakeTrafficSecret
+        logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret)
+        logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret)
         setRxState ctx usedHash usedCipher serverHandshakeTrafficSecret
         return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret)
 
@@ -831,11 +824,8 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
             serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf
             exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf
         usingState_ ctx $ setExporterMasterSecret exporterMasterSecret
-        -- putStrLn $ "hChSf: " ++ showBytesHex hChSf
-        -- putStrLn $ "masterSecret: " ++ showBytesHex masterSecret
-        -- dumpKey ctx "SERVER_TRAFFIC_SECRET_0" serverApplicationTrafficSecret0
-        -- dumpKey ctx "CLIENT_TRAFFIC_SECRET_0" clientApplicationTrafficSecret0
-        -- putStrLn "---- setTxState ctx usedHash usedCipher clientApplicationTrafficSecret0"
+        logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0)
+        logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0)
         setTxState ctx usedHash usedCipher clientApplicationTrafficSecret0
         setRxState ctx usedHash usedCipher serverApplicationTrafficSecret0
         return masterSecret

core/Network/TLS/Handshake/Common13.hs

@@ -26,7 +26,6 @@ module Network.TLS.Handshake.Common13
        , getCurrentTimeFromBase
        , getSessionData13
        , safeNonNegative32
-       , dumpKey
        , RecvHandshake13M
        , runRecvHandshake13
        , recvHandshake13
@@ -57,7 +56,6 @@ import Network.TLS.Struct13
 import Network.TLS.Types
 import Network.TLS.Wire
 import Network.TLS.Util
-import System.IO
 import Time.System
 
 import Control.Monad.State.Strict
@@ -261,20 +259,6 @@ safeNonNegative32 x
   | x <= 0                = 0
   | finiteBitSize x <= 32 = x
   | otherwise             = x `min` fromIntegral (maxBound :: Word32)
-
-----------------------------------------------------------------
-
-dumpKey :: Context -> String -> ByteString -> IO ()
-dumpKey ctx label key = do
-    mhst <- getHState ctx
-    case mhst of
-      Nothing  -> return ()
-      Just hst -> do
-          let cr = unClientRandom $ hstClientRandom hst
-          hPutStrLn stderr $ label ++ " " ++ dump cr ++ " " ++ dump key
-  where
-    dump = init . tail . showBytesHex
-
 ----------------------------------------------------------------
 
 newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)

core/Network/TLS/Handshake/Key.hs

@@ -18,6 +18,8 @@ module Network.TLS.Handshake.Key
     , generateFFDHE
     , generateFFDHEShared
     , getLocalDigitalSignatureAlg
+    , logKey
+    , LogKey(..)
     ) where
 
 import Control.Monad.State.Strict
@@ -30,6 +32,7 @@ import Network.TLS.Crypto
 import Network.TLS.Types
 import Network.TLS.Context.Internal
 import Network.TLS.Imports
+import Network.TLS.Struct
 
 {- if the RSA encryption fails we just return an empty bytestring, and let the protocol
  - fail by itself; however it would be probably better to just report it since it's an internal problem.
@@ -86,3 +89,40 @@ getLocalDigitalSignatureAlg ctx = do
     case findDigitalSignatureAlg keys of
         Just sigAlg -> return sigAlg
         Nothing     -> fail "selected credential does not support signing"
+
+----------------------------------------------------------------
+
+data LogKey = MasterSecret ByteString
+            | ClientEarlyTrafficSecret ByteString
+            | ServerHandshakeTrafficSecret ByteString
+            | ClientHandshakeTrafficSecret ByteString
+            | ServerTrafficSecret0 ByteString
+            | ClientTrafficSecret0 ByteString
+
+labelAndKey :: LogKey -> (String, ByteString)
+labelAndKey (MasterSecret key) =
+    ("CLIENT_RANDOM", key)
+labelAndKey (ClientEarlyTrafficSecret key) =
+    ("CLIENT_EARLY_TRAFFIC_SECRET", key)
+labelAndKey (ServerHandshakeTrafficSecret key) =
+    ("SERVER_HANDSHAKE_TRAFFIC_SECRET", key)
+labelAndKey (ClientHandshakeTrafficSecret key) =
+    ("CLIENT_HANDSHAKE_TRAFFIC_SECRET", key)
+labelAndKey (ServerTrafficSecret0 key) =
+    ("SERVER_TRAFFIC_SECRET_0", key)
+labelAndKey (ClientTrafficSecret0 key) =
+    ("CLIENT_TRAFFIC_SECRET_0", key)
+
+-- NSS Key Log Format
+-- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format
+logKey :: Context -> LogKey -> IO ()
+logKey ctx logkey = do
+    mhst <- getHState ctx
+    case mhst of
+      Nothing  -> return ()
+      Just hst -> do
+          let cr = unClientRandom $ hstClientRandom hst
+              (label,key) = labelAndKey logkey
+          ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key
+  where
+    dump = init . tail . showBytesHex

core/Network/TLS/Handshake/Process.hs

@@ -94,7 +94,7 @@ processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do
     (rver, role, random) <- usingState_ ctx $ do
         (,,) <$> getVersion <*> isClientContext <*> genRandom 48
     ePremaster <- decryptRSA ctx encryptedPremaster
-    usingHState ctx $ do
+    masterSecret <- usingHState ctx $ do
         expectedVer <- gets hstClientVersion
         case ePremaster of
             Left _          -> setMasterSecretFromPre rver role random
@@ -103,6 +103,8 @@ processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do
                 Right (ver, _)
                     | ver /= expectedVer -> setMasterSecretFromPre rver role random
                     | otherwise          -> setMasterSecretFromPre rver role premaster
+    liftIO $ logKey ctx (MasterSecret masterSecret)
+
 processClientKeyXchg ctx (CKX_DH clientDHValue) = do
     rver <- usingState_ ctx getVersion
     role <- usingState_ ctx isClientContext
@@ -114,7 +116,8 @@ processClientKeyXchg ctx (CKX_DH clientDHValue) = do
 
     dhpriv       <- usingHState ctx getDHPrivate
     let premaster = dhGetShared params dhpriv clientDHValue
-    usingHState ctx $ setMasterSecretFromPre rver role premaster
+    masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster
+    liftIO $ logKey ctx (MasterSecret masterSecret)
 
 processClientKeyXchg ctx (CKX_ECDH bytes) = do
     ServerECDHParams grp _ <- usingHState ctx getServerECDHParams
@@ -126,7 +129,8 @@ processClientKeyXchg ctx (CKX_ECDH bytes) = do
               Just premaster -> do
                   rver <- usingState_ ctx getVersion
                   role <- usingState_ ctx isClientContext
-                  usingHState ctx $ setMasterSecretFromPre rver role premaster
+                  masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster
+                  liftIO $ logKey ctx (MasterSecret masterSecret)
               Nothing -> throwCore $ Error_Protocol ("cannote generate a shared secret on ECDH", True, HandshakeFailure)
 
 processClientFinished :: Context -> FinishedData -> IO ()

core/Network/TLS/Handshake/Server.hs

@@ -306,7 +306,9 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes
             usingState_ ctx (setSession clientSession True)
             serverhello <- makeServerHello clientSession
             sendPacket ctx $ Handshake [serverhello]
-            usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData
+            let masterSecret = sessionSecret sessionData
+            usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret
+            logKey ctx (MasterSecret masterSecret)
             sendChangeCipherAndFinish ctx ServerRole
             recvChangeCipherAndFinish ctx
     handshakeTerminate ctx
@@ -686,9 +688,6 @@ handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts clientCiphers _
     keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of
           Just (KeyShareClientHello kses) -> return kses
           _                               -> throwCore $ Error_Protocol ("key exchange not implemented", True, HandshakeFailure)
-    -- putStrLn $ "keyshare = " ++ show (map keyShareEntryGroup keyShares)
-    -- putStrLn "Handshake messages:"
-    -- usingHState ctx getHandshakeMessages >>= mapM_ (putStrLn . showBytesHex)
     case findKeyShare keyShares serverGroups of
       Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession
       Just keyShare -> do
@@ -728,10 +727,7 @@ doHandshake13 sparams cred@(certChain, _) ctx chosenVersion usedCipher exts used
     hCh <- transcriptHash ctx
     let earlySecret = hkdfExtract usedHash zero psk
         clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh
-    -- dumpKey ctx "CLIENT_EARLY_TRAFFIC_SECRET" clientEarlyTrafficSecret
-    -- putStrLn $ "hCh: " ++ showBytesHex hCh
-    -- putStrLn $ "earlySecret: " ++ showBytesHex earlySecret
-    -- putStrLn $ "clientEarlyTrafficSecret: " ++ showBytesHex clientEarlyTrafficSecret
+    logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)
     extensions <- checkBinder earlySecret binderInfo
     let authenticated = isJust binderInfo
         rtt0OK = authenticated && rtt0 && rtt0accept && is0RTTvalid
@@ -757,18 +753,9 @@ doHandshake13 sparams cred@(certChain, _) ctx chosenVersion usedCipher exts used
         hChSh <- transcriptHash ctx
         let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh
             serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh
-        -- putStrLn $ "handshakeSecret: " ++ showBytesHex handshakeSecret
-        -- putStrLn $ "hChSh: " ++ showBytesHex hChSh
-        -- usingHState ctx getHandshakeMessages >>= mapM_ (putStrLn . showBytesHex)
-        -- dumpKey ctx "SERVER_HANDSHAKE_TRAFFIC_SECRET" serverHandshakeTrafficSecret
-        -- dumpKey ctx "CLIENT_HANDSHAKE_TRAFFIC_SECRET" clientHandshakeTrafficSecret
-{-
-        if rtt0OK then
-           putStrLn "---- setRxState ctx usedHash usedCipher clientEarlyTrafficSecret"
-         else
-           putStrLn "---- setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret"
--}
         liftIO $ do
+            logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret)
+            logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret)
             setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlyTrafficSecret else clientHandshakeTrafficSecret
             setTxState ctx usedHash usedCipher serverHandshakeTrafficSecret
     ----------------------------------------------------------------
@@ -787,10 +774,8 @@ doHandshake13 sparams cred@(certChain, _) ctx chosenVersion usedCipher exts used
         exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf
     usingState_ ctx $ setExporterMasterSecret exporterMasterSecret
     ----------------------------------------------------------------
-    -- putStrLn $ "hChSf: " ++ showBytesHex hChSf
-    -- putStrLn $ "masterSecret: " ++ showBytesHex masterSecret
-    -- dumpKey ctx "SERVER_TRAFFIC_SECRET_0" serverApplicationTrafficSecret0
-    -- dumpKey ctx "CLIENT_TRAFFIC_SECRET_0" clientApplicationTrafficSecret0
+    logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0)
+    logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0)
     setTxState ctx usedHash usedCipher serverApplicationTrafficSecret0
     ----------------------------------------------------------------
     let established

core/Network/TLS/Handshake/State.hs

@@ -396,10 +396,11 @@ setMasterSecretFromPre :: ByteArrayAccess preMaster
                        => Version   -- ^ chosen transmission version
                        -> Role      -- ^ the role (Client or Server) of the generating side
                        -> preMaster -- ^ the pre master secret
-                       -> HandshakeM ()
+                       -> HandshakeM ByteString
 setMasterSecretFromPre ver role premasterSecret = do
     secret <- genSecret <$> get
     setMasterSecret ver role secret
+    return secret
   where genSecret hst =
             generateMasterSecret ver (fromJust "cipher" $ hstPendingCipher hst)
                                  premasterSecret

core/Network/TLS/Parameters.hs

@@ -55,13 +55,16 @@ data DebugParams = DebugParams
     , debugPrintSeed :: Seed -> IO ()
       -- | Force to choose this version in the server side.
     , debugVersionForced :: Maybe Version
+      -- | Printing master keys. The default is no printing.
+    , debugKeyLogger     :: String -> IO ()
     }
 
 defaultDebugParams :: DebugParams
 defaultDebugParams = DebugParams
     { debugSeed = Nothing
     , debugPrintSeed = const (return ())
     , debugVersionForced = Nothing
+    , debugKeyLogger = \_ -> return ()
     }
 
 instance Show DebugParams where