Key update

core/Network/TLS.hs

@@ -98,6 +98,7 @@ module Network.TLS
     , sendData
     , recvData
     , recvData'
+    , updateKey
 
     -- * Crypto Key
     , PubKey(..)

core/Network/TLS/Core.hs

@@ -27,6 +27,7 @@ module Network.TLS.Core
     , sendData
     , recvData
     , recvData'
+    , updateKey
     ) where
 
 import Network.TLS.Cipher
@@ -44,15 +45,13 @@ import Network.TLS.Handshake.Common13
 import Network.TLS.Handshake.State
 import Network.TLS.Handshake.State13
 import Network.TLS.KeySchedule
-import Network.TLS.Record.State
 import Network.TLS.Util (catchException)
 import Network.TLS.Extension
 import qualified Network.TLS.State as S
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as L
 import qualified Control.Exception as E
-import Control.Concurrent.MVar (readMVar)
 
 import Control.Monad.State.Strict
 
@@ -152,11 +151,9 @@ recvData13 ctx = liftIO $ do
         -- Only the first one is used at this moment.
         process (Handshake13 (NewSessionTicket13 life add nonce label exts:_)) = do
             ResuptionSecret resumptionMasterSecret <- usingHState ctx getTLS13Secret
-            tx <- readMVar (ctxTxState ctx)
-            let Just usedCipher = stCipher tx
-                usedHash = cipherHash usedCipher
-                hashSize = hashDigestSize usedHash
-            let psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize
+            (usedHash, usedCipher, _) <- getTxState ctx
+            let hashSize = hashDigestSize usedHash
+                psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize
                 maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of
                   Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms
                   _                                    -> 0
@@ -166,6 +163,26 @@ recvData13 ctx = liftIO $ do
             -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"
             recvData13 ctx
         -- 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
+                keyUpdate ctx getRxState setRxState
+                usingState_ ctx $ S.setTLS13KeyUpdateSent False
+                recvData13 ctx
+              else do
+                let reason = "received key update before established"
+                terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
+        process (Handshake13 [KeyUpdate13 UpdateRequested]) = do
+            established <- ctxEstablished ctx
+            if established == Established then do
+                keyUpdate ctx getRxState setRxState
+                sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]
+                keyUpdate ctx getTxState setTxState
+                recvData13 ctx
+              else do
+                let reason = "received key update before established"
+                terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
         process (AppData13 "") = recvData13 ctx
         process (AppData13 x) = do
             established <- ctxEstablished ctx
@@ -212,3 +229,24 @@ terminate' ctx send err level desc reason = do
 -- | same as recvData but returns a lazy bytestring.
 recvData' :: MonadIO m => Context -> m L.ByteString
 recvData' ctx = recvData ctx >>= return . L.fromChunks . (:[])
+
+keyUpdate :: Context
+          -> (Context -> IO (Hash,Cipher,C8.ByteString))
+          -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ())
+          -> IO ()
+keyUpdate ctx getState setState = do
+    (usedHash, usedCipher, applicationTrafficSecretN) <- getState ctx
+    let applicationTrafficSecretN1 = hkdfExpandLabel usedHash applicationTrafficSecretN "traffic upd" "" $ hashDigestSize usedHash
+    setState ctx usedHash usedCipher applicationTrafficSecretN1
+
+-- | 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
+    tls13 <- tls13orLater ctx
+    when tls13 $ do
+        sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateRequested]
+        usingState_ ctx $ S.setTLS13KeyUpdateSent True
+        keyUpdate ctx getTxState setTxState
+    return tls13

core/Network/TLS/Handshake/State13.hs

@@ -8,7 +8,9 @@
 -- Portability : unknown
 --
 module Network.TLS.Handshake.State13
-       ( setTxState
+       ( getTxState
+       , getRxState
+       , setTxState
        , setRxState
        , setHelloParameters13
        , transcriptHash
@@ -29,6 +31,22 @@ import Network.TLS.Record.State
 import Network.TLS.Imports
 import Network.TLS.Util
 
+getTxState :: Context -> IO (Hash, Cipher, ByteString)
+getTxState ctx = getXState ctx ctxTxState
+
+getRxState :: Context -> IO (Hash, Cipher, ByteString)
+getRxState ctx = getXState ctx ctxRxState
+
+getXState :: Context
+          -> (Context -> MVar RecordState)
+          -> IO (Hash, Cipher, ByteString)
+getXState ctx func = do
+    tx <- readMVar (func ctx)
+    let Just usedCipher = stCipher tx
+        usedHash = cipherHash usedCipher
+        secret = cstMacSecret $ stCryptState tx
+    return (usedHash, usedCipher, secret)
+
 setTxState :: Context -> Hash -> Cipher -> ByteString -> IO ()
 setTxState = setXState ctxTxState BulkEncrypt
 
@@ -49,7 +67,7 @@ setXState func encOrDec ctx h cipher secret =
     cst = CryptState {
         cstKey       = bulkInit bulk encOrDec key
       , cstIV        = iv
-      , cstMacSecret = "" -- not used in TLS 1.3
+      , cstMacSecret = secret
       }
     rt = RecordState {
         stCryptState  = cst

core/Network/TLS/Packet13.hs

@@ -69,6 +69,9 @@ encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $
     putOpaque16 label
     putExtensions exts
 encodeHandshake13' EndOfEarlyData13 = ""
+encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0
+encodeHandshake13' (KeyUpdate13 UpdateRequested)    = runPut $ putWord8 1
+
 encodeHandshake13' _ = error "encodeHandshake13'"
 
 encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString
@@ -99,6 +102,7 @@ decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of
     HandshakeType_CertVerify13          -> decodeCertVerify13
     HandshakeType_NewSessionTicket13    -> decodeNewSessionTicket13
     HandshakeType_EndOfEarlyData13      -> return EndOfEarlyData13
+    HandshakeType_KeyUpdate13           -> decodeKeyUpdate13
     _fixme                              -> error $ "decodeHandshake13 " ++ show _fixme
 
 decodeFinished13 :: Get Handshake13
@@ -140,6 +144,14 @@ decodeNewSessionTicket13 = do
     exts   <- getExtensions len
     return $ NewSessionTicket13 life ageadd nonce label exts
 
+decodeKeyUpdate13 :: Get Handshake13
+decodeKeyUpdate13 = do
+    ru <- getWord8
+    case ru of
+        0 -> return $ KeyUpdate13 UpdateNotRequested
+        1 -> return $ KeyUpdate13 UpdateRequested
+        x -> fail $ "Unknown request_update: " ++ show x
+
 hrrRandom :: ServerRandom
 hrrRandom = ServerRandom $ B.pack [
     0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11

core/Network/TLS/Record/State.hs

@@ -41,6 +41,8 @@ import qualified Data.ByteString as B
 data CryptState = CryptState
     { cstKey        :: !BulkState
     , cstIV         :: !ByteString
+    -- In TLS 1.2 or earlier, this holds mac secret.
+    -- In TLS 1.3, this holds application traffic secret N.
     , cstMacSecret  :: !ByteString
     } deriving (Show)
 

core/Network/TLS/State.hs

@@ -56,6 +56,8 @@ module Network.TLS.State
     , getTLS13HRR
     , setTLS13Cookie
     , getTLS13Cookie
+    , setTLS13KeyUpdateSent
+    , getTLS13KeyUpdateSent
     -- * random
     , genRandom
     , withRNG
@@ -98,6 +100,7 @@ data TLSState = TLSState
     , stTLS13PreSharedKey   :: Maybe PreSharedKey
     , stTLS13HRR            :: !Bool
     , stTLS13Cookie         :: Maybe Cookie
+    , stTLS13KeyUpdateSent  :: !Bool
     , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3
     }
 
@@ -137,6 +140,7 @@ newTLSState rng clientContext = TLSState
     , stTLS13PreSharedKey   = Nothing
     , stTLS13HRR            = False
     , stTLS13Cookie         = Nothing
+    , stTLS13KeyUpdateSent  = False
     , stExporterMasterSecret = Nothing
     }
 
@@ -289,3 +293,9 @@ 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

core/Network/TLS/Struct13.hs

@@ -13,6 +13,7 @@ module Network.TLS.Struct13
        , ContentType(..)
        , contentType
        , protoToContent
+       , KeyUpdate(..)
        ) where
 
 import Data.X509 (CertificateChain)
@@ -27,6 +28,10 @@ data Packet13 =
     | AppData13 ByteString
     deriving (Show,Eq)
 
+data KeyUpdate = UpdateNotRequested
+               | UpdateRequested
+               deriving (Show,Eq)
+
 -- fixme: convert ByteString to proper data types.
 data Handshake13 =
       ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw]
@@ -38,7 +43,7 @@ data Handshake13 =
     | Certificate13 ByteString CertificateChain [[ExtensionRaw]]
     | CertVerify13 HashAndSignatureAlgorithm ByteString
     | Finished13 FinishedData
-    | KeyUpdate13 Word8
+    | KeyUpdate13 KeyUpdate
     deriving (Show,Eq)
 
 data HandshakeType13 =

core/Tests/Tests.hs

@@ -50,25 +50,29 @@ prop_pipe_work = do
 recvDataNonNull :: Context -> IO C8.ByteString
 recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l
 
-runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan C8.ByteString -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()
-runTLSPipe params tlsServer tlsClient = do
+runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()
+runTLSPipeN n params tlsServer tlsClient = do
     (writeStart, readResult) <- run (establishDataPipe params tlsServer tlsClient)
     -- send some data
-    d <- B.pack <$> pick (someWords8 256)
-    run $ writeStart d
+    ds <- replicateM n $ do
+        d <- B.pack <$> pick (someWords8 256)
+        _ <- run $ writeStart d
+        return d
     -- receive it
-    dres <- run $ timeout 60000000 readResult -- 60 sec
+    dsres <- run $ timeout 60000000 readResult -- 60 sec
     -- check if it equal
-    Just d `assertEq` dres
-    return ()
+    Just ds `assertEq` dsres
+
+runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()
+runTLSPipe = runTLSPipeN 1
 
 runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO ()
 runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient
   where tlsServer ctx queue = do
             handshake ctx
             checkInfoPredicate ctx
             d <- recvDataNonNull ctx
-            writeChan queue d
+            writeChan queue [d]
             return ()
         tlsClient queue ctx = do
             handshake ctx
@@ -95,7 +99,7 @@ runTLSPipeSimple13 params modes mEarlyData = runTLSPipe params tlsServer tlsClie
                     ed' <- recvDataNonNull ctx
                     ed `assertEq` ed'
             d <- recvDataNonNull ctx
-            writeChan queue d
+            writeChan queue [d]
             minfo <- contextGetInformation ctx
             Just (snd modes) `assertEq` (minfo >>= infoTLS13HandshakeMode)
             return ()
@@ -108,6 +112,28 @@ runTLSPipeSimple13 params modes mEarlyData = runTLSPipe params tlsServer tlsClie
             bye ctx
             return ()
 
+runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO ()
+runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient
+  where tlsServer ctx queue = do
+            handshake ctx
+            d0 <- recvDataNonNull ctx
+            _ <- updateKey ctx
+            d1 <- recvDataNonNull ctx
+            d2 <- recvDataNonNull ctx
+            writeChan queue [d0,d1,d2]
+            return ()
+        tlsClient queue ctx = do
+            handshake ctx
+            d0 <- readChan queue
+            sendData ctx (L.fromChunks [d0])
+            d1 <- readChan queue
+            sendData ctx (L.fromChunks [d1])
+            _ <- updateKey ctx
+            d2 <- readChan queue
+            sendData ctx (L.fromChunks [d2])
+            bye ctx
+            return ()
+
 runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO ()
 runTLSInitFailure params = do
     (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient)
@@ -136,6 +162,11 @@ prop_handshake13_initiate = do
         hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest
     runTLSPipeSimple13 params (hs,hs) Nothing
 
+prop_handshake_keyupdate :: PropertyM IO ()
+prop_handshake_keyupdate = do
+    params <- pick arbitraryPairParams
+    runTLSPipeSimpleKeyUpdate params
+
 prop_handshake13_full :: PropertyM IO ()
 prop_handshake13_full = do
     (cli, srv) <- pick arbitraryPairParams13
@@ -459,7 +490,7 @@ prop_handshake_alpn = do
             proto <- getNegotiatedProtocol ctx
             Just "h2" `assertEq` proto
             d <- recvDataNonNull ctx
-            writeChan queue d
+            writeChan queue [d]
             return ()
         tlsClient queue ctx = do
             handshake ctx
@@ -486,7 +517,7 @@ prop_handshake_sni = do
             sni <- getClientSNI ctx
             Just serverName `assertEq` sni
             d <- recvDataNonNull ctx
-            writeChan queue d
+            writeChan queue [d]
             return ()
         tlsClient queue ctx = do
             handshake ctx
@@ -512,7 +543,7 @@ prop_handshake_renegotiation = do
   where tlsServer ctx queue = do
             handshake ctx
             d <- recvDataNonNull ctx
-            writeChan queue d
+            writeChan queue [d]
             return ()
         tlsClient queue ctx = do
             handshake ctx
@@ -565,6 +596,7 @@ main = defaultMain $ testGroup "tls"
             [ testProperty "Setup" (monadicIO prop_pipe_work)
             , testProperty "Initiation" (monadicIO prop_handshake_initiate)
             , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate)
+            , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate)
             , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures)
             , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites)
             , testProperty "Groups" (monadicIO prop_handshake_groups)

debug/src/SimpleClient.hs

@@ -160,6 +160,7 @@ data Flag = Verbose | Debug | IODebug | NoValidateCert | Session | Http11
           | DebugPrintSeed
           | Group String
           | Help
+          | UpdateKey
           deriving (Show,Eq)
 
 options :: [OptDescr Flag]
@@ -172,6 +173,7 @@ options =
     , Option ['O']  ["output"]  (ReqArg Output "stdout") "output "
     , Option ['g']  ["group"]  (ReqArg Group "group") "group"
     , Option ['t']  ["timeout"] (ReqArg Timeout "timeout") "timeout in milliseconds (2s by default)"
+    , Option ['u']  ["update-key"]   (NoArg UpdateKey) "Updating keys after sending the first request then sending the same request again (TLS 1.3 only)"
     , Option []     ["no-validation"] (NoArg NoValidateCert) "disable certificate validation"
     , Option []     ["client-cert"] (ReqArg ClientCert "cert-file:key-file") "add a client certificate to use with the server"
     , Option []     ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"
@@ -260,6 +262,10 @@ runOn (sStorage, certStore) flags port hostname
                     _ -> return ()
                 sendData ctx $ query
                 loopRecv out ctx
+                when (UpdateKey `elem` flags) $ do
+                    _tls13 <- updateKey ctx
+                    sendData ctx $ query
+                    loopRecv out ctx
                 bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e
                 return ()
         setup = maybe (return stdout) (flip openFile AppendMode) getOutput