Merge branch 'ticket'

core/Network/TLS/Context/Internal.hs

@@ -102,6 +102,7 @@ data Information = Information
     , infoClientRandom :: Maybe ClientRandom
     , infoServerRandom :: Maybe ServerRandom
     , infoSupportedGroup :: Maybe Group
+    , infoTLS12Resumption :: Bool
     , infoTLS13HandshakeMode :: Maybe HandshakeMode13
     , infoIsEarlyDataAccepted :: Bool
     }
@@ -212,8 +213,12 @@ contextGetInformation ctx = do
     let accepted = case hstate of
             Just st -> hstTLS13RTT0Status st == RTT0Accepted
             Nothing -> False
+    tls12resumption <- usingState_ ctx isSessionResuming
     case (ver, cipher) of
-        (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted
+        (Just v, Just c) ->
+            return $
+                Just $
+                    Information v c comp ms ems cr sr grp tls12resumption hm13 accepted
         _ -> return Nothing
 
 contextSend :: Context -> ByteString -> IO ()

core/Network/TLS/Core.hs

@@ -33,7 +33,7 @@ module Network.TLS.Core (
 ) where
 
 import qualified Control.Exception as E
-import Control.Monad (unless, when)
+import Control.Monad (unless, void, when)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy as L
@@ -121,20 +121,20 @@ recvData ctx = liftIO $ do
         -- packet, because don't want another thread to receive a new packet
         -- before this one has been fully processed.
         --
-        -- Even when recvData1/recvData13 loops, we only need to call function
+        -- Even when recvData12/recvData13 loops, we only need to call function
         -- checkValid once.  Since we hold the read lock, no concurrent call
         -- will impact the validity of the context.
-        if tls13 then recvData13 ctx else recvData1 ctx
+        if tls13 then recvData13 ctx else recvData12 ctx
 
-recvData1 :: Context -> IO B.ByteString
-recvData1 ctx = do
+recvData12 :: Context -> IO B.ByteString
+recvData12 ctx = do
     pkt <- recvPacket ctx
     either (onError terminate) process pkt
   where
     process (Handshake [ch@ClientHello{}]) =
-        handshakeWith ctx ch >> recvData1 ctx
+        handshakeWith ctx ch >> recvData12 ctx
     process (Handshake [hr@HelloRequest]) =
-        handshakeWith ctx hr >> recvData1 ctx
+        handshakeWith ctx hr >> recvData12 ctx
     process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty
     process (Alert [(AlertLevel_Fatal, desc)]) = do
         setEOF ctx
@@ -146,7 +146,7 @@ recvData1 ctx = do
             )
 
     -- when receiving empty appdata, we just retry to get some data.
-    process (AppData "") = recvData1 ctx
+    process (AppData "") = recvData12 ctx
     process (AppData x) = return x
     process p =
         let reason = "unexpected message " ++ show p
@@ -229,7 +229,7 @@ recvData13 ctx = do
             tinfo <- createTLS13TicketInfo life7d (Right add) Nothing
             sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk
             let label' = B.copy label
-            sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata
+            void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata
         -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"
         loopHandshake13 hs
     loopHandshake13 (KeyUpdate13 mode : hs) = do

core/Network/TLS/Crypto.hs

@@ -58,7 +58,6 @@ import qualified Crypto.PubKey.RSA.PSS as PSS
 import Crypto.Random
 import qualified Data.ByteArray as B (convert)
 import qualified Data.ByteString as B
-import Data.Maybe (fromJust)
 
 import Data.X509 (
     PrivKey (..),

core/Network/TLS/Crypto/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 -- |
@@ -27,8 +28,9 @@ module Network.TLS.Crypto.Types (
 ) where
 
 import Data.Word
+import GHC.Generics
 
-newtype Group = Group Word16 deriving (Eq)
+newtype Group = Group Word16 deriving (Eq, Generic)
 
 {- FOURMOLU_DISABLE -}
 pattern P256      :: Group

core/Network/TLS/Extension.hs

@@ -343,15 +343,15 @@ decodeEcPointFormatsSupported =
 
 ------------------------------------------------------------
 
-data SessionTicket = SessionTicket Ticket
+newtype SessionTicket = SessionTicket Ticket
     deriving (Show, Eq)
 
 -- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A
 instance Extension SessionTicket where
     extensionID _ = EID_SessionTicket
-    extensionEncode (SessionTicket ticket) = runPut $ putOpaque16 ticket
-    extensionDecode MsgTClientHello = runGetMaybe $ SessionTicket <$> getOpaque16
-    extensionDecode MsgTServerHello = runGetMaybe $ SessionTicket <$> getOpaque16
+    extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket
+    extensionDecode MsgTClientHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)
+    extensionDecode MsgTServerHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)
     extensionDecode _ = error "extensionDecode: SessionTicket"
 
 ------------------------------------------------------------

core/Network/TLS/Handshake/Client/ClientHello.hs

@@ -5,7 +5,6 @@ module Network.TLS.Handshake.Client.ClientHello (
 ) where
 
 import qualified Data.ByteString as B
-import Data.Maybe (fromJust)
 
 import Network.TLS.Cipher
 import Network.TLS.Compression
@@ -56,10 +55,11 @@ sendClientHello cparams ctx groups mparams = do
         crand <- clientRandom ctx
         let paramSession = case clientWantSessionResume cparams of
                 Nothing -> Session Nothing
-                Just (sid, sdata)
+                Just (sidOrTkt, sdata)
                     | sessionVersion sdata >= TLS13 -> Session Nothing
                     | ems == RequireEMS && noSessionEMS -> Session Nothing
-                    | otherwise -> Session (Just sid)
+                    | isTicket sidOrTkt -> Session $ Just $ toSessionID sidOrTkt
+                    | otherwise -> Session (Just sidOrTkt)
                   where
                     noSessionEMS = SessionEMS `notElem` sessionFlags sdata
         -- In compatibility mode a client not offering a pre-TLS 1.3
@@ -98,7 +98,8 @@ sendClientHello' cparams ctx groups clientSession crand = do
         Nothing -> return Nothing
         Just info -> Just <$> send0RTT info
     unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo
-    return (rtt0, map (\(ExtensionRaw i _) -> i) extensions)
+    let sentExtensions = map (\(ExtensionRaw i _) -> i) extensions
+    return (rtt0, sentExtensions)
   where
     ciphers = supportedCiphers $ ctxSupported ctx
     compressions = supportedCompressions $ ctxSupported ctx
@@ -123,8 +124,8 @@ sendClientHello' cparams ctx groups clientSession crand = do
             , emsExtension
             , groupExtension
             , ecPointExtension
-            , -- , sessionTicketExtension
-              signatureAlgExtension
+            , sessionTicketExtension
+            , signatureAlgExtension
             , -- , heartbeatExtension
               versionExtension
             , earlyDataExtension rtt0
@@ -175,7 +176,12 @@ sendClientHello' cparams ctx groups clientSession crand = do
                     EcPointFormatsSupported [EcPointFormat_Uncompressed]
     -- [EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]
     -- heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend
-    -- sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket
+
+    sessionTicketExtension = do
+        case clientWantSessionResume cparams of
+            Just (sidOrTkt, _)
+                | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt
+            _ -> return $ Just $ toExtensionRaw $ SessionTicket ""
 
     signatureAlgExtension =
         return $
@@ -211,21 +217,23 @@ sendClientHello' cparams ctx groups clientSession crand = do
     getPskInfo =
         case sessionAndCipherToResume13 of
             Nothing -> return Nothing
-            Just (sid, sdata, sCipher) -> do
+            Just (identity, sdata, sCipher) -> do
                 let tinfo = fromJust $ sessionTicketInfo sdata
                 age <- getAge tinfo
                 return $
                     if isAgeValid age tinfo
-                        then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo)
+                        then
+                            Just
+                                (identity, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo)
                         else Nothing
 
     preSharedKeyExtension pskInfo =
         case pskInfo of
             Nothing -> return Nothing
-            Just (sid, _, choice, obfAge) ->
+            Just (identity, _, choice, obfAge) ->
                 let zero = cZero choice
-                    identity = PskIdentity sid obfAge
-                    offeredPsks = PreSharedKeyClientHello [identity] [zero]
+                    pskIdentity = PskIdentity identity obfAge
+                    offeredPsks = PreSharedKeyClientHello [pskIdentity] [zero]
                  in return $ Just $ toExtensionRaw offeredPsks
 
     pskExchangeModeExtension

core/Network/TLS/Handshake/Client/ServerHello.hs

@@ -131,8 +131,8 @@ processServerHello ctx cparams clientSession sentExts (ServerHello rver serverRa
 
     let resumingSession =
             case clientWantSessionResume cparams of
-                Just (sessionId, sessionData) ->
-                    if serverSession == Session (Just sessionId) then Just sessionData else Nothing
+                Just (_, sessionData) ->
+                    if serverSession == clientSession then Just sessionData else Nothing
                 Nothing -> Nothing
     usingState_ ctx $ setSession serverSession (isJust resumingSession)
 
@@ -161,6 +161,7 @@ processServerExtension (ExtensionRaw extID content)
         setTLS13KeyShare $ extensionDecode msgt content
     | extID == EID_PreSharedKey =
         setTLS13PreSharedKey $ extensionDecode MsgTServerHello content
+    | extID == EID_SessionTicket = setTLS12SessionTicket "" -- empty ticket
 processServerExtension _ = return ()
 
 ----------------------------------------------------------------

core/Network/TLS/Handshake/Client/TLS12.hs

@@ -20,8 +20,9 @@ import Network.TLS.Handshake.Signature
 import Network.TLS.Handshake.State
 import Network.TLS.IO
 import Network.TLS.Imports
-import Network.TLS.Packet hiding (getExtensions)
+import Network.TLS.Packet hiding (getExtensions, getSession)
 import Network.TLS.Parameters
+import Network.TLS.Session
 import Network.TLS.State
 import Network.TLS.Struct
 import Network.TLS.Types
@@ -35,45 +36,35 @@ recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()
 recvServerFirstFlight12 cparams ctx hs = do
     resuming <- usingState_ ctx isSessionResuming
     if resuming
-        then do
-            let st = RecvStatePacket expectChangeCipher
-            runRecvStateHS ctx st hs
+        then recvNSTandCCSandFinish ctx
         else do
-            let st = RecvStateHandshake (processCertificate cparams ctx)
+            let st = RecvStateHandshake (expectCertificate cparams ctx)
             runRecvStateHS ctx st hs
 
-expectChangeCipher :: Packet -> IO (RecvState IO)
-expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
-expectChangeCipher p = unexpected (show p) (Just "change cipher")
-
-expectFinish :: Handshake -> IO (RecvState IO)
-expectFinish (Finished _) = return RecvStateDone
-expectFinish p = unexpected (show p) (Just "Handshake Finished")
-
-processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
-processCertificate cparams ctx (Certificates certs) = do
+expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
+expectCertificate cparams ctx (Certificates certs) = do
     doCertificate cparams ctx certs
-    return $ RecvStateHandshake (processServerKeyExchange ctx)
-processCertificate _ ctx p = processServerKeyExchange ctx p
+    return $ RecvStateHandshake (expectServerKeyExchange ctx)
+expectCertificate _ ctx p = expectServerKeyExchange ctx p
 
-processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
-processServerKeyExchange ctx (ServerKeyXchg origSkx) = do
+expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
+expectServerKeyExchange ctx (ServerKeyXchg origSkx) = do
     doServerKeyExchange ctx origSkx
-    return $ RecvStateHandshake (processCertificateRequest ctx)
-processServerKeyExchange ctx p = processCertificateRequest ctx p
+    return $ RecvStateHandshake (expectCertificateRequest ctx)
+expectServerKeyExchange ctx p = expectCertificateRequest ctx p
 
-processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
-processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do
+expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
+expectCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do
     let cTypes = filter (<= lastSupportedCertificateType) cTypesSent
     usingHState ctx $ setCertReqCBdata $ Just (cTypes, Just sigAlgs, dNames)
-    return $ RecvStateHandshake (processServerHelloDone ctx)
-processCertificateRequest ctx p = do
+    return $ RecvStateHandshake (expectServerHelloDone ctx)
+expectCertificateRequest ctx p = do
     usingHState ctx $ setCertReqCBdata Nothing
-    processServerHelloDone ctx p
+    expectServerHelloDone ctx p
 
-processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
-processServerHelloDone _ ServerHelloDone = return RecvStateDone
-processServerHelloDone _ p = unexpected (show p) (Just "server hello data")
+expectServerHelloDone :: Context -> Handshake -> IO (RecvState m)
+expectServerHelloDone _ ServerHelloDone = return RecvStateDone
+expectServerHelloDone _ p = unexpected (show p) (Just "server hello data")
 
 ----------------------------------------------------------------
 
@@ -89,8 +80,40 @@ sendClientSecondFlight12 cparams ctx = do
 recvServerSecondFlight12 :: Context -> IO ()
 recvServerSecondFlight12 ctx = do
     sessionResuming <- usingState_ ctx isSessionResuming
-    unless sessionResuming $ recvChangeCipherAndFinish ctx
-    handshakeDone ctx
+    unless sessionResuming $ recvNSTandCCSandFinish ctx
+    mticket <- usingState_ ctx getTLS12SessionTicket
+    identity <- case mticket of
+      Just ticket -> return ticket
+      Nothing -> do
+          session <- usingState_ ctx getSession
+          case session of
+            Session (Just sessionId) -> return $ B.copy sessionId
+            _ -> return "" -- never reach
+    sessionData <- getSessionData ctx
+    void $ sessionEstablish
+        (sharedSessionManager $ ctxShared ctx)
+        identity
+        (fromJust sessionData)
+    handshakeDone12 ctx
+
+recvNSTandCCSandFinish :: Context -> IO ()
+recvNSTandCCSandFinish ctx = do
+    st <- isJust <$> usingState_ ctx getTLS12SessionTicket
+    if st
+        then runRecvState ctx $ RecvStateHandshake expectNewSessionTicket
+        else do runRecvState ctx $ RecvStatePacket expectChangeCipher
+  where
+    expectNewSessionTicket (NewSessionTicket _ ticket) = do
+        usingState_ ctx $ setTLS12SessionTicket ticket
+        return $ RecvStatePacket expectChangeCipher
+    expectNewSessionTicket p = unexpected (show p) (Just "Handshake Finished")
+
+    expectChangeCipher ChangeCipherSpec = do
+        return $ RecvStateHandshake expectFinish
+    expectChangeCipher p = unexpected (show p) (Just "change cipher")
+
+    expectFinish (Finished _) = return RecvStateDone
+    expectFinish p = unexpected (show p) (Just "Handshake Finished")
 
 ----------------------------------------------------------------