Merge PR haskell-tls#314.

kazu-yamamoto · Nov 26, 2018 · 11cc2ef · 11cc2ef
2 parents 29066f9 + bf83458
commit 11cc2ef
Show file tree

Hide file tree

Showing 5 changed files with 23 additions and 20 deletions.
diff --git a/core/Network/TLS.hs b/core/Network/TLS.hs
@@ -99,6 +99,7 @@ module Network.TLS
     , recvData
     , recvData'
     , updateKey
+    , KeyUpdateRequest(..)
 
     -- * Crypto Key
     , PubKey(..)

diff --git a/core/Network/TLS/Core.hs b/core/Network/TLS/Core.hs
@@ -28,6 +28,7 @@ module Network.TLS.Core
     , recvData
     , recvData'
     , updateKey
+    , KeyUpdateRequest(..)
     ) where
 
 import Network.TLS.Cipher
@@ -165,10 +166,12 @@ recvData13 ctx = liftIO $ do
         -- when receiving empty appdata, we just retry to get some data.
         process (Handshake13 [KeyUpdate13 UpdateNotRequested]) = do
             established <- ctxEstablished ctx
-            waitForNotRequested <- usingState_ ctx S.getTLS13KeyUpdateSent
-            if established == Established && waitForNotRequested then do
+            -- Though RFC 8446 Sec 4.6.3 does not clearly says,
+            -- unidirectional key update is legal.
+            -- So, we don't have to check if this key update is corresponding
+            -- to key update (update_requested) which we sent.
+            if established == Established then do
                 keyUpdate ctx getRxState setRxState
-                usingState_ ctx $ S.setTLS13KeyUpdateSent False
                 recvData13 ctx
               else do
                 let reason = "received key update before established"
@@ -239,14 +242,21 @@ keyUpdate ctx getState setState = do
     let applicationTrafficSecretN1 = hkdfExpandLabel usedHash applicationTrafficSecretN "traffic upd" "" $ hashDigestSize usedHash
     setState ctx usedHash usedCipher applicationTrafficSecretN1
 
+-- | How to update keys in TLS 1.3
+data KeyUpdateRequest = OneWay -- ^ Unidirectional key update
+                      | TwoWay -- ^ Bidirectional key update (normal case)
+                      deriving (Eq, Show)
+
 -- | Updating appication traffic secrets for TLS 1.3.
 --   If this API is called for TLS 1.3, 'True' is returned.
 --   Otherwise, 'False' is returned.
-updateKey :: Context -> IO Bool
-updateKey ctx = do
+updateKey :: Context -> KeyUpdateRequest -> IO Bool
+updateKey ctx way = do
     tls13 <- tls13orLater ctx
     when tls13 $ do
-        sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateRequested]
-        usingState_ ctx $ S.setTLS13KeyUpdateSent True
+        let req = case way of
+                OneWay -> UpdateNotRequested
+                TwoWay -> UpdateRequested
+        sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]
         keyUpdate ctx getTxState setTxState
     return tls13
diff --git a/core/Network/TLS/State.hs b/core/Network/TLS/State.hs
@@ -56,8 +56,6 @@ module Network.TLS.State
     , getTLS13HRR
     , setTLS13Cookie
     , getTLS13Cookie
-    , setTLS13KeyUpdateSent
-    , getTLS13KeyUpdateSent
     -- * random
     , genRandom
     , withRNG
@@ -100,7 +98,6 @@ data TLSState = TLSState
     , stTLS13PreSharedKey   :: Maybe PreSharedKey
     , stTLS13HRR            :: !Bool
     , stTLS13Cookie         :: Maybe Cookie
-    , stTLS13KeyUpdateSent  :: !Bool
     , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3
     }
 
@@ -140,7 +137,6 @@ newTLSState rng clientContext = TLSState
     , stTLS13PreSharedKey   = Nothing
     , stTLS13HRR            = False
     , stTLS13Cookie         = Nothing
-    , stTLS13KeyUpdateSent  = False
     , stExporterMasterSecret = Nothing
     }
 
@@ -293,9 +289,3 @@ setTLS13Cookie cookie = modify (\st -> st { stTLS13Cookie = Just cookie })
 
 getTLS13Cookie :: TLSSt (Maybe Cookie)
 getTLS13Cookie = gets stTLS13Cookie
-
-setTLS13KeyUpdateSent :: Bool -> TLSSt ()
-setTLS13KeyUpdateSent b = modify (\st -> st { stTLS13KeyUpdateSent = b })
-
-getTLS13KeyUpdateSent :: TLSSt Bool
-getTLS13KeyUpdateSent = gets stTLS13KeyUpdateSent
diff --git a/core/Tests/Tests.hs b/core/Tests/Tests.hs
@@ -122,7 +122,8 @@ runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient
   where tlsServer ctx queue = do
             handshake ctx
             d0 <- recvDataNonNull ctx
-            _ <- updateKey ctx
+            req <- generate $ elements [OneWay, TwoWay]
+            _ <- updateKey ctx req
             d1 <- recvDataNonNull ctx
             d2 <- recvDataNonNull ctx
             writeChan queue [d0,d1,d2]
@@ -133,7 +134,8 @@ runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient
             sendData ctx (L.fromChunks [d0])
             d1 <- readChan queue
             sendData ctx (L.fromChunks [d1])
-            _ <- updateKey ctx
+            req <- generate $ elements [OneWay, TwoWay]
+            _ <- updateKey ctx req
             d2 <- readChan queue
             sendData ctx (L.fromChunks [d2])
             bye ctx

diff --git a/debug/src/SimpleClient.hs b/debug/src/SimpleClient.hs
@@ -263,7 +263,7 @@ runOn (sStorage, certStore) flags port hostname
                 sendData ctx $ query
                 loopRecv out ctx
                 when (UpdateKey `elem` flags) $ do
-                    _tls13 <- updateKey ctx
+                    _tls13 <- updateKey ctx TwoWay
                     sendData ctx $ query
                     loopRecv out ctx
                 bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e