Do not use pending actions without 0-RTT

core/Network/TLS/Context/Internal.hs

@@ -21,7 +21,7 @@ module Network.TLS.Context.Internal
     , Context(..)
     , Hooks(..)
     , Established(..)
-    , PendingAction
+    , PendingAction(..)
     , ctxEOF
     , ctxHasSSLv2ClientHello
     , ctxDisableSSLv2ClientHello
@@ -135,7 +135,11 @@ data Established = NotEstablished
                  | Established
                  deriving (Eq, Show)
 
-type PendingAction = (Handshake13 -> IO (), IO ())
+data PendingAction
+    = PendingAction (Handshake13 -> IO ())
+      -- ^ simple pending action
+    | PendingActionHash (ByteString -> Handshake13 -> IO ())
+      -- ^ pending action taking transcript hash up to preceding message
 
 updateMeasure :: Context -> (Measurement -> Measurement) -> IO ()
 updateMeasure ctx f = do

core/Network/TLS/Core.hs

@@ -234,13 +234,17 @@ recvData13 ctx = do
             case mPendingAction of
                 Nothing -> let reason = "unexpected handshake message " ++ show h in
                            terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
-                Just (pa, postAction) -> do
+                Just action -> do
                     -- Pending actions are executed with read+write locks, just
                     -- like regular handshake code.
-                    withWriteLock ctx $ handleException ctx $ do
-                        pa h
-                        processHandshake13 ctx h
-                        postAction
+                    withWriteLock ctx $ handleException ctx $
+                        case action of
+                            PendingAction pa ->
+                                processHandshake13 ctx h >> pa h
+                            PendingActionHash pa -> do
+                                d <- transcriptHash ctx
+                                processHandshake13 ctx h
+                                pa d h
                     loopHandshake13 hs
 
         terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)

core/Network/TLS/Handshake/Client.hs

@@ -804,9 +804,9 @@ handshakeClient13' :: ClientParams -> Context -> Cipher -> Hash -> IO ()
 handshakeClient13' cparams ctx usedCipher usedHash = do
     (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret
     rtt0accepted <- runRecvHandshake13 $ do
-        accepted <- recvHandshake13preUpdate ctx expectEncryptedExtensions
-        unless resuming $ recvHandshake13preUpdate ctx expectCertRequest
-        recvFinished serverHandshakeTrafficSecret
+        accepted <- recvHandshake13 ctx expectEncryptedExtensions
+        unless resuming $ recvHandshake13 ctx expectCertRequest
+        recvHandshake13hash ctx $ expectFinished serverHandshakeTrafficSecret
         return accepted
     hChSf <- transcriptHash ctx
     when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])
@@ -888,7 +888,7 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
 
     expectCertRequest (CertRequest13 token exts) = do
         processCertRequest13 ctx token exts
-        recvHandshake13preUpdate ctx expectCertAndVerify
+        recvHandshake13 ctx expectCertAndVerify
 
     expectCertRequest other = do
         usingHState ctx $ do
@@ -901,8 +901,7 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
         _ <- liftIO $ processCertificate cparams ctx (Certificates cc)
         let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc
         usingHState ctx $ setPublicKey pubkey
-        hChSc <- transcriptHash ctx
-        recvHandshake13preUpdate ctx $ expectCertVerify pubkey hChSc
+        recvHandshake13hash ctx $ expectCertVerify pubkey
     expectCertAndVerify p = unexpected (show p) (Just "server certificate")
 
     expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do
@@ -911,14 +910,10 @@ handshakeClient13' cparams ctx usedCipher usedHash = do
         unless ok $ decryptError "cannot verify CertificateVerify"
     expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify")
 
-    recvFinished serverHandshakeTrafficSecret = do
-        hChSv <- transcriptHash ctx
-        let verifyData' = makeVerifyData usedHash serverHandshakeTrafficSecret hChSv
-        recvHandshake13preUpdate ctx $ expectFinished verifyData'
-
-    expectFinished verifyData' (Finished13 verifyData) =
+    expectFinished baseKey hashValue (Finished13 verifyData) = do
+        let verifyData' = makeVerifyData usedHash baseKey hashValue
         when (verifyData' /= verifyData) $ decryptError "cannot verify finished"
-    expectFinished _ p = unexpected (show p) (Just "server finished")
+    expectFinished _ _ p = unexpected (show p) (Just "server finished")
 
     setResumptionSecret masterSecret = do
         hChCf <- transcriptHash ctx

core/Network/TLS/Handshake/Common13.hs

@@ -30,8 +30,8 @@ module Network.TLS.Handshake.Common13
        , safeNonNegative32
        , RecvHandshake13M
        , runRecvHandshake13
-       , recvHandshake13preUpdate
-       , recvHandshake13postUpdate
+       , recvHandshake13
+       , recvHandshake13hash
        ) where
 
 import qualified Data.ByteArray as BA
@@ -288,24 +288,19 @@ safeNonNegative32 x
 newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)
     deriving (Functor, Applicative, Monad, MonadIO)
 
-recvHandshake13preUpdate :: MonadIO m
-                         => Context
-                         -> (Handshake13 -> RecvHandshake13M m a)
-                         -> RecvHandshake13M m a
-recvHandshake13preUpdate ctx f = do
-    h <- getHandshake13 ctx
-    liftIO $ processHandshake13 ctx h
-    f h
-
-recvHandshake13postUpdate :: MonadIO m
-                          => Context
-                          -> (Handshake13 -> RecvHandshake13M m a)
-                          -> RecvHandshake13M m a
-recvHandshake13postUpdate ctx f = do
-    h <- getHandshake13 ctx
-    v <- f h
-    liftIO $ processHandshake13 ctx h
-    return v
+recvHandshake13 :: MonadIO m
+                => Context
+                -> (Handshake13 -> RecvHandshake13M m a)
+                -> RecvHandshake13M m a
+recvHandshake13 ctx f = getHandshake13 ctx >>= f
+
+recvHandshake13hash :: MonadIO m
+                    => Context
+                    -> (ByteString -> Handshake13 -> RecvHandshake13M m a)
+                    -> RecvHandshake13M m a
+recvHandshake13hash ctx f = do
+    d <- transcriptHash ctx
+    getHandshake13 ctx >>= f d
 
 getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13
 getHandshake13 ctx = RecvHandshake13M $ do
@@ -314,7 +309,7 @@ getHandshake13 ctx = RecvHandshake13M $ do
         (h:hs) -> found h hs
         []     -> recvLoop
   where
-    found h hs = put hs >> return h
+    found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h
     recvLoop = do
         epkt <- recvPacket13 ctx
         case epkt of

core/Network/TLS/Handshake/Server.hs

@@ -757,32 +757,30 @@ doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash client
       else when (established == NotEstablished) $
         setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding
 
-    let expectFinished (Finished13 verifyData') = do
-            hChBeforeCf <- transcriptHash ctx
+    let expectFinished hChBeforeCf (Finished13 verifyData') = do
             let verifyData = makeVerifyData usedHash clientHandshakeTrafficSecret hChBeforeCf
             if verifyData == verifyData' then liftIO $ do
                 setEstablished ctx Established
                 setRxState ctx usedHash usedCipher clientApplicationTrafficSecret0
                else
                 decryptError "cannot verify finished"
-        expectFinished hs = unexpected (show hs) (Just "finished 13")
+            liftIO $ sendNewSessionTicket masterSecret sfSentTime
+        expectFinished _ hs = unexpected (show hs) (Just "finished 13")
 
     let expectEndOfEarlyData EndOfEarlyData13 =
             setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret
         expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data")
-    let sendNST = sendNewSessionTicket masterSecret sfSentTime
 
     if not authenticated && serverWantClientCert sparams then
         runRecvHandshake13 $ do
-          skip <- recvHandshake13postUpdate ctx expectCertificate
-          unless skip $ recvHandshake13postUpdate ctx (expectCertVerify sparams ctx)
-          recvHandshake13postUpdate ctx expectFinished
-          liftIO sendNST
+          skip <- recvHandshake13 ctx expectCertificate
+          unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)
+          recvHandshake13hash ctx expectFinished
       else if rtt0OK then
-        setPendingActions ctx [(expectEndOfEarlyData, return ())
-                              ,(expectFinished, sendNST)]
-      else do
-        setPendingActions ctx [(expectFinished, sendNST)]
+        setPendingActions ctx [PendingAction expectEndOfEarlyData
+                              ,PendingActionHash expectFinished]
+      else
+        runRecvHandshake13 $ recvHandshake13hash ctx expectFinished
   where
     setServerParameter = do
         srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams
@@ -941,9 +939,8 @@ doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash client
     hashSize = hashDigestSize usedHash
     zero = B.replicate hashSize 0
 
-expectCertVerify :: MonadIO m => ServerParams -> Context -> Handshake13 -> m ()
-expectCertVerify sparams ctx (CertVerify13 sigAlg sig) = liftIO $ do
-    hChCc <- transcriptHash ctx
+expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
+expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do
     certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected"
     pubkey <- case cc of
                 [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)
@@ -952,7 +949,7 @@ expectCertVerify sparams ctx (CertVerify13 sigAlg sig) = liftIO $ do
     let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)
     verif <- checkCertVerify ctx keyAlg sigAlg sig hChCc
     clientCertVerify sparams ctx certs verif
-expectCertVerify _ _ hs = unexpected (show hs) (Just "certificate verify 13")
+expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13")
 
 helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m ()
 helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do
@@ -1126,22 +1123,20 @@ postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = d
 
     (usedHash, _, applicationTrafficSecretN) <- getRxState ctx
 
-    let expectFinished (Finished13 verifyData') = do
-            hChBeforeCf <- transcriptHash ctx
+    let expectFinished hChBeforeCf (Finished13 verifyData') = do
             let verifyData = makeVerifyData usedHash applicationTrafficSecretN hChBeforeCf
             unless (verifyData == verifyData') $
                 decryptError "cannot verify finished"
-        expectFinished hs = unexpected (show hs) (Just "finished 13")
-
-        postAction = void $ restoreHState ctx baseHState
+            void $ restoreHState ctx baseHState
+        expectFinished _ hs = unexpected (show hs) (Just "finished 13")
 
     -- Note: here the server could send updated NST too, however the library
     -- currently has no API to handle resumption and client authentication
     -- together, see discussion in #133
     if isNullCertificateChain certs
-        then setPendingActions ctx [ (expectFinished, postAction) ]
-        else setPendingActions ctx [ (expectCertVerify sparams ctx, mempty)
-                                   , (expectFinished, postAction)
+        then setPendingActions ctx [ PendingActionHash expectFinished ]
+        else setPendingActions ctx [ PendingActionHash (expectCertVerify sparams ctx)
+                                   , PendingActionHash expectFinished
                                    ]
 
 postHandshakeAuthServerWith _ _ _ =

core/Network/TLS/Handshake/State13.hs

@@ -17,6 +17,7 @@ module Network.TLS.Handshake.State13
        , setHelloParameters13
        , transcriptHash
        , wrapAsMessageHash13
+       , PendingAction(..)
        , setPendingActions
        , popPendingAction
        ) where