diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Version 2.1.0 + +* Breaking change: stop exporting constructors to maintain future + compatibilities. Use `def` and `noSessionManager` instead. +* `onServerFinished` is added to `ClientHooks`. +* `clientWantSessionResumeList` is added to `ClientParams` to support + multiple tickets for TLS 1.3. + ## Version 2.0.6 * Setting `supportedCiphers` in `defaultSupported` to `ciphersuite_default`. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -30,25 +30,85 @@ -- intentionally hide the internal methods even haddock warns. TLSParams, - ClientParams (..), + + -- ** Client parameters + ClientParams, defaultParamsClient, - ServerParams (..), + clientUseMaxFragmentLength, + clientServerIdentification, + clientUseServerNameIndication, + clientWantSessionResume, + clientWantSessionResumeList, + clientShared, + clientHooks, + clientSupported, + clientDebug, + clientUseEarlyData, + -- ** Server parameters + ServerParams, + serverWantClientCert, + serverCACertificates, + serverDHEParams, + serverHooks, + serverShared, + serverSupported, + serverDebug, + serverEarlyDataSize, + serverTicketLifetime, + -- ** Shared - Shared (..), + Shared, + sharedCredentials, + sharedSessionManager, + sharedCAStore, + sharedValidationCache, + sharedHelloExtensions, - -- ** Hooks - ClientHooks (..), + -- ** Client hooks + ClientHooks, OnCertificateRequest, + onCertificateRequest, OnServerCertificate, - ServerHooks (..), - Measurement (..), + onServerCertificate, + onSuggestALPN, + onCustomFFDHEGroup, + onServerFinished, + -- ** Server hooks + ServerHooks, + onClientCertificate, + onUnverifiedClientCert, + onCipherChoosing, + onServerNameIndication, + onNewHandshake, + onALPNClientSuggest, + onEncryptedExtensionsCreating, + Measurement, + nbHandshakes, + bytesReceived, + bytesSent, + -- ** Supported - Supported (..), + Supported, + supportedVersions, + supportedCiphers, + supportedCompressions, + supportedHashSignatures, + supportedSecureRenegotiation, + supportedClientInitiatedRenegotiation, + supportedExtendedMainSecret, + supportedSession, + supportedFallbackScsv, + supportedEmptyPacket, + supportedGroups, -- ** Debug parameters - DebugParams (..), + DebugParams, + debugSeed, + debugPrintSeed, + debugVersionForced, + debugKeyLogger, -- * Shared parameters @@ -61,14 +121,32 @@ credentialLoadX509ChainFromMemory, -- ** Session manager - SessionManager (..), + SessionManager, noSessionManager, + sessionResume, + sessionResumeOnlyOnce, + sessionEstablish, + sessionInvalidate, + sessionUseTicket, SessionID, SessionIDorTicket, Ticket, - SessionData (..), + + -- ** Session data + SessionData, + sessionVersion, + sessionCipher, + sessionCompression, + sessionClientSNI, + sessionSecret, + sessionGroup, + sessionTicketInfo, + sessionALPN, + sessionMaxEarlyDataSize, + sessionFlags, SessionFlag (..), TLS13TicketInfo, + is0RTTPossible, -- ** Validation Cache ValidationCache (..), @@ -109,8 +187,19 @@ contextClose, -- ** Information gathering - Information (..), + Information, contextGetInformation, + infoVersion, + infoCipher, + infoCompression, + infoMainSecret, + infoExtendedMainSecret, + infoClientRandom, + infoServerRandom, + infoSupportedGroup, + infoTLS12Resumption, + infoTLS13HandshakeMode, + infoIsEarlyDataAccepted, ClientRandom, ServerRandom, unClientRandom, @@ -133,14 +222,22 @@ getPeerFinished, -- ** Modifying hooks in context - Hooks (..), + Hooks, + hookRecvHandshake, + hookRecvHandshake13, + hookRecvCertificates, + hookLogging, contextModifyHooks, Handshake, contextHookSetHandshakeRecv, Handshake13, contextHookSetHandshake13Recv, contextHookSetCertificateRecv, - Logging (..), + Logging, + loggingPacketSent, + loggingPacketRecv, + loggingIOSent, + loggingIORecv, Header (..), ProtocolType (..), contextHookSetLogging, diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -266,7 +266,7 @@ exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString) exporter ctx label context outlen = do - msecret <- usingState_ ctx getExporterSecret + msecret <- usingState_ ctx getTLS13ExporterSecret mcipher <- failOnEitherError $ runRxRecordState ctx $ gets stCipher return $ case (msecret, mcipher) of (Just secret, Just cipher) -> diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -80,7 +80,6 @@ import Network.TLS.Backend import Network.TLS.Cipher -import Network.TLS.Compression (Compression) import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Control @@ -97,24 +96,9 @@ import Network.TLS.Types import Network.TLS.Util --- | Information related to a running context, e.g. current cipher -data Information = Information - { infoVersion :: Version - , infoCipher :: Cipher - , infoCompression :: Compression - , infoMainSecret :: Maybe ByteString - , infoExtendedMainSecret :: Bool - , infoClientRandom :: Maybe ClientRandom - , infoServerRandom :: Maybe ServerRandom - , infoSupportedGroup :: Maybe Group - , infoTLS12Resumption :: Bool - , infoTLS13HandshakeMode :: Maybe HandshakeMode13 - , infoIsEarlyDataAccepted :: Bool - } - deriving (Show, Eq) - -- | A TLS Context keep tls specific state, parameters and backend information. -data Context = forall a. +data Context + = forall a. Monoid a => Context { ctxBackend :: Backend @@ -200,6 +184,7 @@ , tls13stClientExtensions :: [ExtensionRaw] -- client , tls13stChoice :: ~CipherChoice -- client , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client + -- Actuall session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] } @@ -301,12 +286,24 @@ let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False - tls12resumption <- usingState_ ctx isSessionResuming + tls12resumption <- usingState_ ctx getTLS12SessionResuming case (ver, cipher) of (Just v, Just c) -> return $ Just $ - Information v c comp ms ems cr sr grp tls12resumption hm13 accepted + Information + { infoVersion = v + , infoCipher = c + , infoCompression = comp + , infoMainSecret = ms + , infoExtendedMainSecret = ems + , infoClientRandom = cr + , infoServerRandom = sr + , infoSupportedGroup = grp + , infoTLS12Resumption = tls12resumption + , infoTLS13HandshakeMode = hm13 + , infoIsEarlyDataAccepted = accepted + } _ -> return Nothing contextSend :: Context -> ByteString -> IO () diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -298,7 +298,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do + loopHandshake13 (NewSessionTicket13 life add nonce ticket exts : hs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only" @@ -318,8 +318,8 @@ life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk - let label' = B.copy label - void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata + let ticket' = B.copy ticket + void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hs loopHandshake13 (KeyUpdate13 mode : hs) = do @@ -379,7 +379,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do + loopHandshake13 (NewSessionTicket13 life add nonce ticket exts : hs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ let reason = "Session ticket is allowed for client only" @@ -399,8 +399,8 @@ life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk - let label' = B.copy label - void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata + let ticket' = B.copy ticket + void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hs loopHandshake13 (h : hs) = do @@ -439,11 +439,11 @@ return True checkAlignment :: Context -> [Handshake13] -> IO () -checkAlignment ctx hs = do +checkAlignment ctx _hs = do complete <- isRecvComplete ctx - unless (complete && null hs) $ + unless complete $ do let reason = "received message not aligned with record boundary" - in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions @@ -470,15 +470,21 @@ -> AlertDescription -> String -> IO a -terminateWithWriteLock ctx send err level desc reason = do - session <- usingState_ ctx getSession - -- Session manager is always invoked with read+write locks, so we merge this - -- with the alert packet being emitted. - withWriteLock ctx $ do - case session of - Session Nothing -> return () - Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid - catchException (send [(level, desc)]) (\_ -> return ()) +terminateWithWriteLock ctx send err level desc reason = withWriteLock ctx $ do + tls13 <- tls13orLater ctx + unless tls13 $ do + -- TLS 1.2 uses the same session ID and session data + -- for all resumed sessions. + -- + -- TLS 1.3 changes session data for every resumed session. + session <- usingState_ ctx getSession + withWriteLock ctx $ do + case session of + Session Nothing -> return () + Session (Just sid) -> + -- calling even session ticket manager anyway + sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid + catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx E.throwIO (Terminated False reason err) diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -10,6 +10,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Client.ClientHello +import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello import Network.TLS.Handshake.Client.TLS12 import Network.TLS.Handshake.Client.TLS13 @@ -37,9 +38,9 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do - groups <- case clientWantSessionResume cparams of - Nothing -> return groupsSupported - Just (_, sdata) -> case sessionGroup sdata of + groups <- case clientSessions cparams of + [] -> return groupsSupported + (_, sdata) : _ -> case sessionGroup sdata of Nothing -> return [] -- TLS 1.2 or earlier Just grp | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported @@ -94,7 +95,7 @@ | otherwise -> do recvServerFirstFlight12 cparams ctx hss sendClientSecondFlight12 cparams ctx - recvServerSecondFlight12 ctx + recvServerSecondFlight12 cparams ctx where groupToSend = listToMaybe groups diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -51,9 +51,9 @@ return crand generateClientHelloParams Nothing = do crand <- clientRandom ctx - let paramSession = case clientWantSessionResume cparams of - Nothing -> Session Nothing - Just (sidOrTkt, sdata) + let paramSession = case clientSessions cparams of + [] -> Session Nothing + (sidOrTkt, sdata) : _ | sessionVersion sdata >= TLS13 -> Session Nothing | ems == RequireEMS && noSessionEMS -> Session Nothing | isTicket sidOrTkt -> Session $ Just $ toSessionID sidOrTkt @@ -178,8 +178,8 @@ -- heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend sessionTicketExtension = do - case clientWantSessionResume cparams of - Just (sidOrTkt, _) + case clientSessions cparams of + (sidOrTkt, _) : _ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt _ -> return $ Just $ toExtensionRaw $ SessionTicket "" @@ -210,10 +210,13 @@ preSharedKeyExtension = case pskInfo of Nothing -> return Nothing - Just (identity, _, choice, obfAge) -> + Just (identities, _, choice, obfAge) -> let zero = cZero choice - pskIdentity = PskIdentity identity obfAge - offeredPsks = PreSharedKeyClientHello [pskIdentity] [zero] + pskIdentities = map (\x -> PskIdentity x obfAge) identities + -- [zero] is a place holds. + -- adjustExtentions will replace them. + binders = replicate (length pskIdentities) zero + offeredPsks = PreSharedKeyClientHello pskIdentities binders in return $ Just $ toExtensionRaw offeredPsks pskExchangeModeExtension @@ -238,18 +241,21 @@ adjustExtentions exts ch = case pskInfo of Nothing -> return exts - Just (_, sdata, choice, _) -> do + Just (identities, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret let ech = encodeHandshake ch h = cHash choice - siz = hashDigestSize h - binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) + siz = (hashDigestSize h + 1) * length identities + 2 + binder <- makePSKBinder ctx earlySecret h siz (Just ech) + -- PSK is shared by the previous TLS session. + -- So, PSK is unique for identities. + let binders = replicate (length identities) binder let exts' = init exts ++ [adjust (last exts)] adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders where - withBinders = replacePSKBinder withoutBinders binder + withBinders = replacePSKBinder withoutBinders binders return exts' getEarlySecretInfo choice = do @@ -271,7 +277,10 @@ ---------------------------------------------------------------- type PreSharedKeyInfo = - (Maybe (SessionID, SessionData, CipherChoice, Second), Maybe CipherChoice, Bool) + ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second) + , Maybe CipherChoice + , Bool + ) getPreSharedKeyInfo :: ClientParams @@ -286,30 +295,32 @@ ciphers = supportedCiphers $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 - sessionAndCipherToResume13 = do - guard tls13 - (sid, sdata) <- clientWantSessionResume cparams - guard (sessionVersion sdata >= TLS13) - let cid = sessionCipher sdata - sCipher <- find (\c -> cipherID c == cid) ciphers - return (sid, sdata, sCipher) - getPskInfo = - case sessionAndCipherToResume13 of - Nothing -> return Nothing - Just (identity, sdata, sCipher) -> do - let tinfo = fromJust $ sessionTicketInfo sdata - age <- getAge tinfo - return $ - if isAgeValid age tinfo - then - Just - ( identity - , sdata - , makeCipherChoice TLS13 sCipher - , ageToObfuscatedAge age tinfo - ) - else Nothing + sessions = case clientSessions cparams of + [] -> Nothing + (sid, sdata) : xs -> do + guard tls13 + guard (sessionVersion sdata >= TLS13) + let cid = sessionCipher sdata + sids = map fst xs + sCipher <- find (\c -> cipherID c == cid) ciphers + Just (sid : sids, sdata, sCipher) + + getPskInfo = case sessions of + Nothing -> return Nothing + Just (identity, sdata, sCipher) -> do + let tinfo = fromJust $ sessionTicketInfo sdata + age <- getAge tinfo + return $ + if isAgeValid age tinfo + then + Just + ( identity + , sdata + , makeCipherChoice TLS13 sCipher + , ageToObfuscatedAge age tinfo + ) + else Nothing get0RTTinfo (_, sdata, choice, _) | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs --- a/Network/TLS/Handshake/Client/Common.hs +++ b/Network/TLS/Handshake/Client/Common.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.Common ( throwMiscErrorOnException, @@ -9,6 +10,7 @@ sigAlgsToCertTypes, setALPN, contextSync, + clientSessions, ) where import Control.Exception (SomeException) @@ -348,3 +350,8 @@ contextSync :: Context -> ClientState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync sync _ -> sync ctx ctl + +clientSessions :: ClientParams -> [(SessionID, SessionData)] +clientSessions ClientParams{..} = case clientWantSessionResume of + Nothing -> clientWantSessionResumeList + Just ent -> clientWantSessionResumeList ++ [ent] diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -117,6 +117,7 @@ let supportedVers = supportedVersions $ clientSupported cparams when (ver == TLS13) $ do + -- TLS 1.3 server MUST echo the session id when (clientSession /= serverSession) $ throwCore $ Error_Protocol @@ -140,16 +141,21 @@ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter - let resumingSession = - case clientWantSessionResume cparams of - Just (_, sessionData) -> - if serverSession == clientSession then Just sessionData else Nothing - Nothing -> Nothing - usingState_ ctx $ setSession serverSession (isJust resumingSession) - if ver == TLS13 - then updateContext13 ctx cipherAlg - else updateContext12 ctx exts resumingSession + then do + -- Session is dummy in TLS 1.3. + usingState_ ctx $ setSession serverSession + updateContext13 ctx cipherAlg + else do + let resumingSession = case clientSessions cparams of + (_, sessionData) : _ -> + if serverSession == clientSession then Just sessionData else Nothing + _ -> Nothing + + usingState_ ctx $ do + setSession serverSession + setTLS12SessionResuming $ isJust resumingSession + updateContext12 ctx exts resumingSession processServerHello _ _ p = unexpected (show p) (Just "server hello") ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs --- a/Network/TLS/Handshake/Client/TLS12.hs +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -34,7 +34,7 @@ recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO () recvServerFirstFlight12 cparams ctx hs = do - resuming <- usingState_ ctx isSessionResuming + resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do @@ -72,32 +72,35 @@ sendClientSecondFlight12 :: ClientParams -> Context -> IO () sendClientSecondFlight12 cparams ctx = do - sessionResuming <- usingState_ ctx isSessionResuming + sessionResuming <- usingState_ ctx getTLS12SessionResuming if sessionResuming then sendCCSandFinished ctx ClientRole else do sendClientCCC cparams ctx sendCCSandFinished ctx ClientRole -recvServerSecondFlight12 :: Context -> IO () -recvServerSecondFlight12 ctx = do - sessionResuming <- usingState_ ctx isSessionResuming +recvServerSecondFlight12 :: ClientParams -> Context -> IO () +recvServerSecondFlight12 cparams ctx = do + sessionResuming <- usingState_ ctx getTLS12SessionResuming unless sessionResuming $ recvNSTandCCSandFinished 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) + session <- usingState_ ctx getSession + let midentity = ticketOrSessionID12 mticket session + case midentity of + Nothing -> return () + Just identity -> do + sessionData <- getSessionData ctx + void $ + sessionEstablish + (sharedSessionManager $ ctxShared ctx) + identity + (fromJust sessionData) handshakeDone12 ctx + liftIO $ do + minfo <- contextGetInformation ctx + case minfo of + Nothing -> return () + Just info -> onServerFinished (clientHooks cparams) info recvNSTandCCSandFinished :: Context -> IO () recvNSTandCCSandFinished ctx = do diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -44,7 +44,7 @@ runRecvHandshake13 $ do recvHandshake13 ctx $ expectEncryptedExtensions ctx unless resuming $ recvHandshake13 ctx $ expectCertRequest cparams ctx - recvHandshake13hash ctx $ expectFinished ctx + recvHandshake13hash ctx $ expectFinished cparams ctx ---------------------------------------------------------------- @@ -228,17 +228,23 @@ expectFinished :: MonadIO m - => Context + => ClientParams + -> Context -> ByteString -> Handshake13 -> m () -expectFinished ctx hashValue (Finished13 verifyData) = do +expectFinished cparams ctx hashValue (Finished13 verifyData) = do st <- liftIO $ getTLS13State ctx let usedHash = cHash $ tls13stChoice st ServerTrafficSecret baseKey = triServer $ fromJust $ tls13stHsKey st checkFinished ctx usedHash baseKey hashValue verifyData + liftIO $ do + minfo <- contextGetInformation ctx + case minfo of + Nothing -> return () + Just info -> onServerFinished (clientHooks cparams) info liftIO $ modifyTLS13State ctx $ \s -> s{tls13stRecvSF = True} -expectFinished _ _ p = unexpected (show p) (Just "server finished") +expectFinished _ _ _ p = unexpected (show p) (Just "server finished") ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -372,12 +378,8 @@ setPendingRecvActions ctx [ PendingRecvAction True expectServerHello - , PendingRecvAction - True - (expectEncryptedExtensions ctx) - , PendingRecvActionHash - True - expectFinishedAndSet + , PendingRecvAction True (expectEncryptedExtensions ctx) + , PendingRecvActionHash True expectFinishedAndSet ] where expectServerHello sh = do @@ -385,7 +387,7 @@ processServerHello13 cparams ctx sh void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do - expectFinished ctx h sf + expectFinished cparams ctx h sf liftIO $ writeIORef (ctxPendingSendAction ctx) $ Just $ diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -8,6 +8,7 @@ newSession, handshakeDone12, ensureNullCompression, + ticketOrSessionID12, -- * sending packets sendCCSandFinished, @@ -34,6 +35,7 @@ import Control.Concurrent.MVar import Control.Exception (IOException, fromException, handle, throwIO) import Control.Monad.State.Strict +import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Compression @@ -310,3 +312,12 @@ usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c + +-- TLS 1.2 distinguishes session ID and session ticket. session +-- ticket. Session ticket is prioritized over session ID. +ticketOrSessionID12 + :: Maybe Ticket -> Session -> Maybe SessionIDorTicket +ticketOrSessionID12 (Just ticket) _ + | ticket /= "" = Just $ B.copy ticket +ticketOrSessionID12 _ (Session (Just sessionId)) = Just $ B.copy sessionId +ticketOrSessionID12 _ _ = Nothing diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -217,12 +217,13 @@ totalLen = B.length x takeLen = totalLen - truncLen -replacePSKBinder :: ByteString -> ByteString -> ByteString -replacePSKBinder pskz binder = identities `B.append` binders +replacePSKBinder :: ByteString -> [ByteString] -> ByteString +replacePSKBinder pskz bds = tLidentities <> binders where - bindersSize = B.length binder + 3 - identities = B.take (B.length pskz - bindersSize) pskz - binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder + tLidentities = B.take (B.length pskz - B.length binders) pskz + -- See instance Extension PreSharedKey + binders = runPut $ putOpaque16 $ runPut (mapM_ putBinder bds) + putBinder = putOpaque8 ---------------------------------------------------------------- @@ -531,7 +532,7 @@ let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf - usingState_ ctx $ setExporterSecret exporterSecret + usingState_ ctx $ setTLS13ExporterSecret exporterSecret let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -80,7 +80,7 @@ requestCertificateServer :: ServerParams -> Context -> IO Bool requestCertificateServer sparams ctx = do tls13 <- tls13orLater ctx - supportsPHA <- usingState_ ctx getClientSupportsPHA + supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA let ok = tls13 && supportsPHA when ok $ do certReqCtx <- newCertReqContext ctx diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -38,7 +38,7 @@ case resumeSessionData of Nothing -> do serverSession <- newSession ctx - usingState_ ctx $ setSession serverSession False + usingState_ ctx $ setSession serverSession serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions @@ -46,7 +46,9 @@ sendPacket12 ctx $ Handshake ff contextFlush ctx Just sessionData -> do - usingState_ ctx $ setSession chSession True + usingState_ ctx $ do + setSession chSession + setTLS12SessionResuming True serverhello <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [serverhello] @@ -60,18 +62,18 @@ recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions - let mticket = + let mSessionTicket = extensionLookup EID_SessionTicket chExtensions >>= extensionDecode MsgTClientHello - case mticket of - Just (SessionTicket ticket) | ticket /= "" -> do - sd <- sessionResume (sharedSessionManager $ ctxShared ctx) ticket + mticket = case mSessionTicket of + Nothing -> Nothing + Just (SessionTicket ticket) -> Just ticket + midentity = ticketOrSessionID12 mticket chSession + case midentity of + Nothing -> return Nothing + Just identity -> do + sd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity validateSession chCiphers serverName ems sd - _ -> case chSession of - (Session (Just clientSessionId)) -> do - sd <- sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId - validateSession chCiphers serverName ems sd - (Session Nothing) -> return Nothing validateSession :: [CipherID] @@ -229,7 +231,7 @@ -> Session -> IO Handshake makeServerHello sparams ctx usedCipher mcred chExts session = do - resuming <- usingState_ ctx isSessionResuming + resuming <- usingState_ ctx getTLS12SessionResuming srand <- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams case mcred of diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -46,8 +46,8 @@ ) sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do newSession ctx >>= \ss -> usingState_ ctx $ do - setSession ss False - setClientSupportsPHA supportsPHA + setSession ss + setTLS13ClientSupportsPHA supportsPHA usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter -- ALPN is used in choosePSK @@ -141,7 +141,7 @@ choosePSK = case extensionLookup EID_PreSharedKey chExtensions >>= extensionDecode MsgTClientHello of - Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge : _) bnds@(bnd : _)) -> do + Just (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) -> do when (null dhModes) $ throwCore $ Error_Protocol "no psk_key_exchange_modes extension" MissingExtension @@ -149,10 +149,13 @@ then do let len = sum (map (\x -> B.length x + 1) bnds) + 2 mgr = sharedSessionManager $ serverShared sparams + -- sessionInvalidate is not used for TLS 1.3 + -- because PSK is always changed. + -- So, identity is not stored in Context. msdata <- if rtt0 - then sessionResumeOnlyOnce mgr sessionId - else sessionResume mgr sessionId + then sessionResumeOnlyOnce mgr identity + else sessionResume mgr identity case msdata of Just sdata -> do let tinfo = fromJust $ sessionTicketInfo sdata diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs --- a/Network/TLS/Handshake/Server/TLS12.hs +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -60,6 +60,11 @@ Session (Just sessionId) -> do sessionData <- getSessionData ctx let sessionId' = B.copy sessionId + -- SessionID method: SessionID is used as key to store + -- SessionData. Nothing is returned. + -- + -- Session ticket method: SessionID is ignored. SessionData + -- is encrypted and returned. sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -131,7 +131,7 @@ , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status - , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) + , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstCCS13Sent :: Bool } diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -19,6 +19,7 @@ GroupUsage (..), CertificateUsage (..), CertificateRejectReason (..), + Information (..), ) where import qualified Data.ByteString as B @@ -29,6 +30,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Extra.Cipher +import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.RNG (Seed) @@ -100,9 +102,19 @@ -- -- Default: 'True' , clientWantSessionResume :: Maybe (SessionID, SessionData) - -- ^ try to establish a connection using this session. + -- ^ try to establish a connection using this session for TLS 1.2/TLS 1.3. + -- This can be used for TLS 1.3 but for backward compatibility purpose only. + -- Use 'clientWantSessionResume13' instead for TLS 1.3. -- -- Default: 'Nothing' + , clientWantSessionResumeList :: [(SessionID, SessionData)] + -- ^ try to establish a connection using one of this sessions + -- especially for TLS 1.3. + -- This take precedence over 'clientWantSessionResume'. + -- For convenience, this can be specified for TLS 1.2 but only the first + -- entry is used. + -- + -- Default: '[]' , clientShared :: Shared -- ^ See the default value of 'Shared'. , clientHooks :: ClientHooks @@ -131,6 +143,7 @@ , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientWantSessionResume = Nothing + , clientWantSessionResumeList = [] , clientShared = def , clientHooks = def , clientSupported = def @@ -535,6 +548,8 @@ -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) -- -- See RFC 7919 section 3.1 for recommandations. + , onServerFinished :: Information -> IO () + -- ^ When a handshake is done, this hook can check `Information`. } defaultClientHooks :: ClientHooks @@ -544,6 +559,7 @@ , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024 + , onServerFinished = \_ -> return () } instance Show ClientHooks where @@ -634,3 +650,19 @@ show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks + +-- | Information related to a running context, e.g. current cipher +data Information = Information + { infoVersion :: Version + , infoCipher :: Cipher + , infoCompression :: Compression + , infoMainSecret :: Maybe ByteString + , infoExtendedMainSecret :: Bool + , infoClientRandom :: Maybe ClientRandom + , infoServerRandom :: Maybe ServerRandom + , infoSupportedGroup :: Maybe Group + , infoTLS12Resumption :: Bool + , infoTLS13HandshakeMode :: Maybe HandshakeMode13 + , infoIsEarlyDataAccepted :: Bool + } + deriving (Show, Eq) diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -5,18 +5,20 @@ import Network.TLS.Types --- | A session manager +-- | A session manager. +-- In the server side, all fields are used. +-- In the client side, only 'sessionEstablish' is used. data SessionManager = SessionManager { sessionResume :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used on TLS 1.2\/1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. , sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used for 0RTT on TLS 1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. - , sessionEstablish :: SessionID -> SessionData -> IO (Maybe Ticket) - -- ^ Used TLS 1.2\/1.3 servers\/clients to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket'. In the client side, 'Nothing' should be returned. For clients, only this field should be set with 'noSessionManager'. - , sessionInvalidate :: SessionID -> IO () - -- ^ Used TLS 1.2\/1.3 servers to delete 'SessionData' with 'SessionID' if @sessionUseTicket@ is 'True'. + , sessionEstablish :: SessionIDorTicket -> SessionData -> IO (Maybe Ticket) + -- ^ Used on TLS 1.2\/1.3 servers to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket' ignoring 'SessionID'. Used on TLS 1.2\/1.3 clients to store 'SessionData' with 'SessionIDorTicket' and then return 'Nothing'. For clients, only this field should be set with 'noSessionManager'. + , sessionInvalidate :: SessionIDorTicket -> IO () + -- ^ Used TLS 1.2 servers to delete 'SessionData' with 'SessionID' on errors. , sessionUseTicket :: Bool - -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that TLS 1.3 servers always use session tickets. + -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that 'SessionID' and 'Ticket' are integrated as identity in TLS 1.3. } -- | The session manager to do nothing. diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -44,10 +44,13 @@ setServerCertificateChain, setSession, getSession, - isSessionResuming, getRole, - setExporterSecret, - getExporterSecret, + -- + setTLS12SessionResuming, + getTLS12SessionResuming, + -- + setTLS13ExporterSecret, + getTLS13ExporterSecret, setTLS13KeyShare, getTLS13KeyShare, setTLS13PreSharedKey, @@ -56,8 +59,8 @@ getTLS13HRR, setTLS13Cookie, getTLS13Cookie, - setClientSupportsPHA, - getClientSupportsPHA, + setTLS13ClientSupportsPHA, + getTLS13ClientSupportsPHA, setTLS12SessionTicket, getTLS12SessionTicket, @@ -80,7 +83,6 @@ data TLSState = TLSState { stSession :: Session - , stSessionResuming :: Bool , -- RFC 5746, Renegotiation Indication Extension -- RFC 5929, Channel Bindings for TLS, "tls-unique" stSecureRenegotiation :: Bool @@ -98,15 +100,18 @@ , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName , stRandomGen :: StateRNG - , stVersion :: Maybe Version , stClientContext :: Role - , stTLS13KeyShare :: Maybe KeyShare + , stVersion :: Maybe Version + , -- + stTLS12SessionResuming :: Bool + , stTLS12SessionTicket :: Maybe Ticket + , -- + stTLS13KeyShare :: Maybe KeyShare , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie - , stExporterSecret :: Maybe ByteString -- TLS 1.3 - , stClientSupportsPHA :: Bool -- Post-Handshake Authentication (TLS 1.3) - , stTLS12SessionTicket :: Maybe Ticket + , stTLS13ExporterSecret :: Maybe ByteString + , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } newtype TLSSt a = TLSSt {runTLSSt :: ErrT TLSError (State TLSState) a} @@ -124,7 +129,6 @@ newTLSState rng clientContext = TLSState { stSession = Session Nothing - , stSessionResuming = False , stSecureRenegotiation = False , stClientVerifyData = Nothing , stServerVerifyData = Nothing @@ -139,15 +143,16 @@ , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng - , stVersion = Nothing , stClientContext = clientContext + , stVersion = Nothing + , stTLS12SessionResuming = False + , stTLS12SessionTicket = Nothing , stTLS13KeyShare = Nothing , stTLS13PreSharedKey = Nothing , stTLS13HRR = False , stTLS13Cookie = Nothing - , stExporterSecret = Nothing - , stClientSupportsPHA = False - , stTLS12SessionTicket = Nothing + , stTLS13ExporterSecret = Nothing + , stTLS13ClientSupportsPHA = False } setVerifyDataForSend :: VerifyData -> TLSSt () @@ -197,15 +202,18 @@ certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake -setSession :: Session -> Bool -> TLSSt () -setSession session resuming = modify (\st -> st{stSession = session, stSessionResuming = resuming}) +setSession :: Session -> TLSSt () +setSession session = modify (\st -> st{stSession = session}) getSession :: TLSSt Session getSession = gets stSession -isSessionResuming :: TLSSt Bool -isSessionResuming = gets stSessionResuming +setTLS12SessionResuming :: Bool -> TLSSt () +setTLS12SessionResuming b = modify (\st -> st{stTLS12SessionResuming = b}) +getTLS12SessionResuming :: TLSSt Bool +getTLS12SessionResuming = gets stTLS12SessionResuming + setVersion :: Version -> TLSSt () setVersion ver = modify (\st -> st{stVersion = Just ver}) @@ -294,10 +302,14 @@ getFirstVerifyData :: TLSSt (Maybe ByteString) getFirstVerifyData = do - resuming <- isSessionResuming - if resuming - then gets stServerVerifyData - else gets stClientVerifyData + ver <- getVersion + case ver of + TLS13 -> gets stServerVerifyData + _ -> do + resuming <- getTLS12SessionResuming + if resuming + then gets stServerVerifyData + else gets stClientVerifyData getRole :: TLSSt Role getRole = gets stClientContext @@ -313,12 +325,18 @@ put (st{stRandomGen = rng'}) return a -setExporterSecret :: ByteString -> TLSSt () -setExporterSecret key = modify (\st -> st{stExporterSecret = Just key}) +setTLS12SessionTicket :: Ticket -> TLSSt () +setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t}) -getExporterSecret :: TLSSt (Maybe ByteString) -getExporterSecret = gets stExporterSecret +getTLS12SessionTicket :: TLSSt (Maybe Ticket) +getTLS12SessionTicket = gets stTLS12SessionTicket +setTLS13ExporterSecret :: ByteString -> TLSSt () +setTLS13ExporterSecret key = modify (\st -> st{stTLS13ExporterSecret = Just key}) + +getTLS13ExporterSecret :: TLSSt (Maybe ByteString) +getTLS13ExporterSecret = gets stTLS13ExporterSecret + setTLS13KeyShare :: Maybe KeyShare -> TLSSt () setTLS13KeyShare mks = modify (\st -> st{stTLS13KeyShare = mks}) @@ -343,14 +361,8 @@ getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie -setClientSupportsPHA :: Bool -> TLSSt () -setClientSupportsPHA b = modify (\st -> st{stClientSupportsPHA = b}) - -getClientSupportsPHA :: TLSSt Bool -getClientSupportsPHA = gets stClientSupportsPHA - -setTLS12SessionTicket :: Ticket -> TLSSt () -setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t}) +setTLS13ClientSupportsPHA :: Bool -> TLSSt () +setTLS13ClientSupportsPHA b = modify (\st -> st{stTLS13ClientSupportsPHA = b}) -getTLS12SessionTicket :: TLSSt (Maybe Ticket) -getTLS12SessionTicket = gets stTLS12SessionTicket +getTLS13ClientSupportsPHA :: TLSSt Bool +getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -10,6 +10,7 @@ isTicket, toSessionID, SessionData (..), + is0RTTPossible, SessionFlag (..), CertReqContext, TLS13TicketInfo (..), @@ -102,6 +103,9 @@ , sessionFlags :: [SessionFlag] } -- sessionFromTicket :: Bool deriving (Show, Eq, Generic) + +is0RTTPossible :: SessionData -> Bool +is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0 -- | Some session flags data SessionFlag diff --git a/test/Session.hs b/test/Session.hs --- a/test/Session.hs +++ b/test/Session.hs @@ -32,7 +32,7 @@ -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref = - SessionManager + noSessionManager { sessionResume = \myId -> readIORef ref >>= maybeResume False myId , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId , sessionEstablish = \myId dat -> writeIORef ref (Just (myId, dat)) >> return Nothing @@ -78,7 +78,7 @@ oneSessionTicket :: SessionManager oneSessionTicket = - SessionManager + noSessionManager { sessionResume = resume , sessionResumeOnlyOnce = resume , sessionEstablish = \_ dat -> return $ Just $ L.toStrict $ serialise dat diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls -version: 2.0.6 +version: 2.1.0 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -180,6 +180,7 @@ build-depends: base >=4.9 && <5, bytestring, + base16-bytestring, containers, crypton, crypton-x509-store, @@ -208,6 +209,7 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, + base16-bytestring, bytestring, crypton, crypton-x509-store, diff --git a/util/Client.hs b/util/Client.hs --- a/util/Client.hs +++ b/util/Client.hs @@ -4,9 +4,11 @@ module Client ( Aux (..), Cli, - client, + clientHTTP11, + clientDNS, ) where +import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Lazy.Char8 as CL8 import Network.Socket import Network.TLS @@ -18,13 +20,13 @@ , auxPort :: ServiceName , auxDebug :: String -> IO () , auxShow :: ByteString -> IO () - , auxReadResumptionData :: IO (Maybe (SessionID, SessionData)) + , auxReadResumptionData :: IO [(SessionID, SessionData)] } type Cli = Aux -> [ByteString] -> Context -> IO () -client :: Cli -client Aux{..} paths ctx = do +clientHTTP11 :: Cli +clientHTTP11 aux@Aux{..} paths ctx = do sendData ctx $ "GET " <> CL8.fromStrict (head paths) @@ -34,11 +36,22 @@ <> "\r\n" <> "Connection: close\r\n" <> "\r\n" - loop + consume ctx aux + +clientDNS :: Cli +clientDNS Aux{..} _paths ctx = do + sendData + ctx + "\x00\x2c\xdc\xe3\x01\x00\x00\x01\x00\x00\x00\x00\x00\x01\x03\x77\x77\x77\x07\x65\x78\x61\x6d\x70\x6c\x65\x03\x63\x6f\x6d\x00\x00\x01\x00\x01\x00\x00\x29\x04\xd0\x00\x00\x00\x00\x00\x00" + bs <- recvData ctx + auxShow $ "Reply: " <> BS16.encode bs auxShow "\n" + +consume :: Context -> Aux -> IO () +consume ctx Aux{..} = loop where loop = do bs <- recvData ctx - when (bs /= "") $ do - auxShow bs - loop + if bs == "" + then auxShow "\n" + else auxShow bs >> loop diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -5,6 +5,7 @@ module Main where import Control.Concurrent +import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8 import Data.Default.Class (def) import Data.IORef @@ -33,6 +34,7 @@ , opt0RTT :: Bool , optRetry :: Bool , optVersions :: [Version] + , optALPN :: String } deriving (Show) @@ -49,6 +51,7 @@ , opt0RTT = False , optRetry = False , optVersions = supportedVersions def + , optALPN = "http/1.1" } usage :: String @@ -106,6 +109,11 @@ ["tls13"] (NoArg (\o -> o{optVersions = [TLS13]})) "use TLS 1.3" + , Option + ['a'] + ["alpn"] + (ReqArg (\a o -> o{optALPN = a}) "") + "set ALPN" ] showUsageAndExit :: String -> IO a @@ -133,7 +141,7 @@ when (null optGroups) $ do putStrLn "Error: unsupported groups" exitFailure - ref <- newIORef Nothing + ref <- newIORef [] let debug | optDebugLog = putStrLn | otherwise = \_ -> return () @@ -150,15 +158,14 @@ } mstore <- if optValidate then Just <$> getSystemCertificateStore else return Nothing - let keyLog = getLogger optKeyLogFile - groups - | optRetry = FFDHE8192 : optGroups - | otherwise = optGroups - cparams = getClientParams optVersions host port groups (smIORef ref) mstore keyLog - runClient opts cparams aux paths + let cparams = getClientParams opts host port (smIORef ref) mstore + client + | optALPN == "dot" = clientDNS + | otherwise = clientHTTP11 + runClient opts client cparams aux paths -runClient :: Options -> ClientParams -> Aux -> [ByteString] -> IO () -runClient opts@Options{..} cparams aux@Aux{..} paths = do +runClient :: Options -> Cli -> ClientParams -> Aux -> [ByteString] -> IO () +runClient opts@Options{..} client cparams aux@Aux{..} paths = do auxDebug "------------------------" (info1, msd) <- runTLS cparams aux $ \ctx -> do i1 <- getInfo ctx @@ -171,7 +178,7 @@ if isResumptionPossible msd then do let cparams2 = modifyClientParams cparams msd False - info2 <- runClient2 opts cparams2 aux paths + info2 <- runClient2 opts client cparams2 aux paths if infoVersion info1 == TLS12 then do if infoTLS12Resumption info2 @@ -196,7 +203,7 @@ if is0RTTPossible info1 msd then do let cparams2 = modifyClientParams cparams msd True - info2 <- runClient2 opts cparams2 aux paths + info2 <- runClient2 opts client cparams2 aux paths if infoTLS13HandshakeMode info2 == Just RTT0 then do putStrLn "Result: (Z) 0-RTT ... OK" @@ -217,18 +224,18 @@ exitFailure | otherwise -> do putStrLn "Result: (H) handshake ... OK" - let malpn = (snd <$> msd) >>= sessionALPN - when (malpn == Just "http/1.1") $ + when (optALPN == "http/1.1") $ putStrLn "Result: (1) HTTP/1.1 transaction ... OK" exitSuccess runClient2 :: Options + -> Cli -> ClientParams -> Aux -> [ByteString] -> IO Information -runClient2 Options{..} cparams aux@Aux{..} paths = do +runClient2 Options{..} client cparams aux@Aux{..} paths = do threadDelay 100000 auxDebug "<<<< next connection >>>>" auxDebug "------------------------" @@ -257,23 +264,21 @@ action ctx modifyClientParams - :: ClientParams -> Maybe (SessionID, SessionData) -> Bool -> ClientParams -modifyClientParams cparams wantResume early = + :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams +modifyClientParams cparams ts early = cparams - { clientWantSessionResume = wantResume + { clientWantSessionResumeList = ts , clientUseEarlyData = early } getClientParams - :: [Version] + :: Options -> HostName -> ServiceName - -> [Group] -> SessionManager -> Maybe CertificateStore - -> (String -> IO ()) -> ClientParams -getClientParams vers serverName port groups sm mstore keyLog = +getClientParams Options{..} serverName port sm mstore = (defaultParamsClient serverName (C8.pack port)) { clientSupported = supported , clientUseServerNameIndication = True @@ -282,6 +287,9 @@ , clientDebug = debug } where + groups + | optRetry = FFDHE8192 : optGroups + | otherwise = optGroups shared = def { sharedSessionManager = sm @@ -292,12 +300,12 @@ } supported = def - { supportedVersions = vers + { supportedVersions = optVersions , supportedGroups = groups } hooks = def - { onSuggestALPN = return $ Just ["http/1.1"] + { onSuggestALPN = return $ Just [C8.pack optALPN] } validateCache | isJust mstore = def @@ -307,20 +315,28 @@ (\_ _ _ -> return ()) debug = def - { debugKeyLogger = keyLog + { debugKeyLogger = getLogger optKeyLogFile } -smIORef :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +smIORef :: IORef [(SessionID, SessionData)] -> SessionManager smIORef ref = noSessionManager - { sessionEstablish = \sid sdata -> writeIORef ref (Just (sid, sdata)) >> return Nothing + { sessionEstablish = \sid sdata -> + modifyIORef' ref (\xs -> (sid, sdata) : xs) + >> printTicket sid sdata + >> return Nothing } -isResumptionPossible :: Maybe (SessionID, SessionData) -> Bool -isResumptionPossible = isJust +printTicket :: SessionID -> SessionData -> IO () +printTicket sid sdata = do + C8.putStr $ "Ticket: " <> C8.take 16 (BS16.encode sid) <> "..., " + putStrLn $ "0-RTT: " <> if sessionMaxEarlyDataSize sdata > 0 then "OK" else "NG" -is0RTTPossible :: Information -> Maybe (SessionID, SessionData) -> Bool -is0RTTPossible _ Nothing = False -is0RTTPossible info (Just (_, sd)) = +isResumptionPossible :: [(SessionID, SessionData)] -> Bool +isResumptionPossible = not . null + +is0RTTPossible :: Information -> [(SessionID, SessionData)] -> Bool +is0RTTPossible _ [] = False +is0RTTPossible info xs = infoVersion info == TLS13 - && sessionMaxEarlyDataSize sd > 0 + && any (\(_, sd) -> sessionMaxEarlyDataSize sd > 0) xs diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -5,6 +5,8 @@ module Main where +import qualified Data.ByteString.Base16 as BS16 +import qualified Data.ByteString.Char8 as C8 import Data.Default.Class (def) import Data.IORef import qualified Data.Map.Strict as M @@ -152,9 +154,17 @@ ref <- newIORef M.empty return $ noSessionManager - { sessionResume = \key -> M.lookup key <$> readIORef ref - , sessionResumeOnlyOnce = \key -> M.lookup key <$> readIORef ref - , sessionEstablish = \key val -> atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing) - , sessionInvalidate = \key -> atomicModifyIORef' ref $ \m -> (M.delete key m, ()) + { sessionResume = \key -> do + C8.putStrLn $ "sessionResume: " <> BS16.encode key + M.lookup key <$> readIORef ref + , sessionResumeOnlyOnce = \key -> do + C8.putStrLn $ "sessionResumeOnlyOnce: " <> BS16.encode key + M.lookup key <$> readIORef ref + , sessionEstablish = \key val -> do + C8.putStrLn $ "sessionEstablish: " <> BS16.encode key + atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing) + , sessionInvalidate = \key -> do + C8.putStrLn $ "sessionEstablish: " <> BS16.encode key + atomicModifyIORef' ref $ \m -> (M.delete key m, ()) , sessionUseTicket = False }