tls 2.1.8 → 2.1.9
raw patch · 69 files changed
+3128/−1364 lines, 69 filesdep +base64-bytestringdep +ech-configdep +hpkedep ~network-run
Dependencies added: base64-bytestring, ech-config, hpke, random
Dependency ranges changed: network-run
Files
- CHANGELOG.md +7/−0
- Network/TLS.hs +11/−5
- Network/TLS/Backend.hs +2/−1
- Network/TLS/Compression.hs +1/−0
- Network/TLS/Context.hs +10/−7
- Network/TLS/Context/Internal.hs +29/−28
- Network/TLS/Core.hs +34/−78
- Network/TLS/Credentials.hs +3/−3
- Network/TLS/Crypto.hs +26/−19
- Network/TLS/Crypto/DH.hs +1/−0
- Network/TLS/Crypto/IES.hs +3/−1
- Network/TLS/Error.hs +4/−0
- Network/TLS/Extension.hs +175/−24
- Network/TLS/Extra/Cipher.hs +7/−7
- Network/TLS/Handshake.hs +1/−2
- Network/TLS/Handshake/Certificate.hs +1/−0
- Network/TLS/Handshake/Client.hs +0/−20
- Network/TLS/Handshake/Client/ClientHello.hs +256/−21
- Network/TLS/Handshake/Client/ServerHello.hs +119/−55
- Network/TLS/Handshake/Client/TLS12.hs +3/−3
- Network/TLS/Handshake/Client/TLS13.hs +21/−15
- Network/TLS/Handshake/Common.hs +108/−31
- Network/TLS/Handshake/Common13.hs +115/−80
- Network/TLS/Handshake/Key.hs +4/−3
- Network/TLS/Handshake/Process.hs +0/−34
- Network/TLS/Handshake/Random.hs +20/−4
- Network/TLS/Handshake/Server.hs +15/−33
- Network/TLS/Handshake/Server/ClientHello.hs +202/−32
- Network/TLS/Handshake/Server/ClientHello12.hs +5/−3
- Network/TLS/Handshake/Server/ClientHello13.hs +107/−38
- Network/TLS/Handshake/Server/ServerHello12.hs +20/−20
- Network/TLS/Handshake/Server/ServerHello13.hs +147/−102
- Network/TLS/Handshake/Server/TLS12.hs +2/−2
- Network/TLS/Handshake/Server/TLS13.hs +176/−54
- Network/TLS/Handshake/State.hs +101/−115
- Network/TLS/Handshake/State13.hs +0/−53
- Network/TLS/Handshake/TranscriptHash.hs +131/−0
- Network/TLS/Hooks.hs +4/−3
- Network/TLS/IO.hs +7/−6
- Network/TLS/IO/Decode.hs +5/−5
- Network/TLS/IO/Encode.hs +18/−19
- Network/TLS/Imports.hs +4/−8
- Network/TLS/KeySchedule.hs +4/−2
- Network/TLS/MAC.hs +1/−0
- Network/TLS/Packet.hs +55/−47
- Network/TLS/Packet13.hs +40/−22
- Network/TLS/Parameters.hs +240/−187
- Network/TLS/PostHandshake.hs +13/−12
- Network/TLS/QUIC.hs +2/−2
- Network/TLS/Record/Decrypt.hs +3/−3
- Network/TLS/Record/Encrypt.hs +3/−3
- Network/TLS/Record/Send.hs +5/−5
- Network/TLS/Record/Types.hs +1/−0
- Network/TLS/State.hs +34/−34
- Network/TLS/Struct.hs +48/−40
- Network/TLS/Struct13.hs +15/−5
- Network/TLS/Types.hs +8/−0
- Network/TLS/Types/Secret.hs +22/−5
- Network/TLS/Util.hs +6/−6
- Network/TLS/Util/ASN1.hs +1/−0
- test/Arbitrary.hs +27/−18
- test/ECHSpec.hs +426/−0
- test/Run.hs +79/−0
- tls.cabal +12/−4
- util/Client.hs +10/−8
- util/Common.hs +7/−0
- util/Server.hs +8/−5
- util/tls-client.hs +78/−3
- util/tls-server.hs +75/−19
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Change log for "tls" +## Version 2.1.9++* Providing ECH(Encrypted Client Hello). See `sharedECHConfigList`,+ `clientUseECH` and `serverECHKey`. Note that the `ech-gen` command,+ `loadECHConfigList` and `loadECHSecretKeys` are provided by the+ `ech-config` package.+ ## Version 2.1.8 * Moving `Limit` to `Shared` to maintain backward compatibility
Network/TLS.hs view
@@ -51,6 +51,7 @@ clientSupported, clientDebug, clientUseEarlyData,+ clientUseECH, -- ** Server parameters ServerParams,@@ -64,6 +65,7 @@ serverDebug, serverEarlyDataSize, serverTicketLifetime,+ serverECHKey, -- ** Shared Shared,@@ -73,6 +75,7 @@ sharedCAStore, sharedValidationCache, sharedHelloExtensions,+ sharedECHConfigList, sharedLimit, -- ** Client hooks@@ -124,6 +127,8 @@ debugPrintSeed, debugVersionForced, debugKeyLogger,+ debugError,+ debugTraceKey, -- ** Limit parameters Limit,@@ -223,6 +228,7 @@ infoTLS12Resumption, infoTLS13HandshakeMode, infoIsEarlyDataAccepted,+ infoIsECHAccepted, ClientRandom, ServerRandom, unClientRandom,@@ -298,6 +304,9 @@ clientUseMaxFragmentLength, ) where +import Data.X509 (PrivKey (..), PubKey (..))+import Data.X509.Validation hiding (HostName, defaultHooks)+ import Network.TLS.Backend (Backend (..), HasBackend (..)) import Network.TLS.Cipher import Network.TLS.Compression (@@ -317,6 +326,7 @@ ) import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks+import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session@@ -340,12 +350,8 @@ import Network.TLS.Types import Network.TLS.X509 -import Data.ByteString as B-import Data.X509 (PrivKey (..), PubKey (..))-import Data.X509.Validation hiding (HostName, defaultHooks)- {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-}-type Bytes = B.ByteString+type Bytes = ByteString -- | Getting certificates from a client, if any. -- Note that the certificates are not sent by a client
Network/TLS/Backend.hs view
@@ -15,8 +15,9 @@ import qualified Data.ByteString as B import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network-import Network.TLS.Imports import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering)++import Network.TLS.Imports -- | Connection IO backend data Backend = Backend
Network/TLS/Compression.hs view
@@ -18,6 +18,7 @@ ) where import Control.Arrow (first)+ import Network.TLS.Imports import Network.TLS.Types (CompressionID)
Network/TLS/Context.hs view
@@ -92,7 +92,6 @@ import Network.TLS.Parameters import Network.TLS.PostHandshake ( postHandshakeAuthClientWith,- postHandshakeAuthServerWith, requestCertificateServer, ) import Network.TLS.RNG@@ -102,7 +101,11 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13-import Network.TLS.Types (Role (..), defaultRecordSizeLimit)+import Network.TLS.Types (+ Role (..),+ TranscriptHash (..),+ defaultRecordSizeLimit,+ ) import Network.TLS.X509 class TLSParams a where@@ -135,7 +138,7 @@ doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer- doPostHandshakeAuthWith = postHandshakeAuthServerWith+ doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified. contextNew@@ -172,11 +175,11 @@ hs <- newMVar Nothing recvActionsRef <- newIORef [] sendActionRef <- newIORef Nothing- crs <- newIORef [] locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ hpkeref <- newIORef Nothing let roleParams = RoleParams { doHandshake_ = doHandshake params@@ -190,6 +193,7 @@ { ctxBackend = getBackend backend , ctxShared = shared , ctxSupported = supported+ , ctxDebug = debug , ctxTLSState = tlsstate , ctxMyRecordLimit = mylimref , ctxPeerRecordLimit = peerlimref@@ -205,12 +209,11 @@ , ctxLocks = locks , ctxPendingRecvActions = recvActionsRef , ctxPendingSendAction = sendActionRef- , ctxCertRequests = crs- , ctxKeyLogger = debugKeyLogger debug , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp , ctxQUICMode = False , ctxTLS13State = st13ref+ , ctxHPKE = hpkeref } syncNoOp _ _ = return ()@@ -287,7 +290,7 @@ return $ case (msecret, mcipher) of (Just secret, Just cipher) -> let h = cipherHash cipher- secret' = deriveSecret h secret label ""+ secret' = deriveSecret h secret label $ TranscriptHash "" label' = "exporter" value' = hash h context key = hkdfExpandLabel h secret' label' value' outlen
Network/TLS/Context/Internal.hs view
@@ -58,8 +58,6 @@ restoreHState, getStateRNG, tls13orLater,- addCertRequest13,- getCertRequest13, decideRecordVersion, -- * Misc@@ -81,6 +79,11 @@ getPeerRecordLimit, checkPeerRecordLimit, newRecordLimitRef,++ -- * ECH+ HPKEF,+ getTLS13HPKE,+ setTLS13HPKE, ) where import Control.Concurrent.MVar@@ -117,6 +120,7 @@ -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared+ , ctxDebug :: DebugParams , ctxTLSState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool@@ -132,13 +136,11 @@ , ctxRoleParams :: RoleParams -- ^ hooks for this context , ctxLocks :: Locks- , ctxKeyLogger :: String -> IO () , ctxHooks :: IORef Hooks , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] , ctxPendingSendAction :: IORef (Maybe (Context -> IO ()))- , ctxCertRequests :: IORef [Handshake13] -- ^ pending post handshake authentication requests , -- QUIC ctxRecordLayer :: RecordLayer a@@ -151,8 +153,11 @@ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3 , ctxPeerRecordLimit :: IORef RecordLimit -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxHPKE :: IORef (Maybe (HPKEF, Int)) } +type HPKEF = ByteString -> ByteString -> IO ByteString+ data RecordLimit = NoRecordLimit -- for QUIC | RecordLimit@@ -267,10 +272,11 @@ data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment.- PendingRecvAction Bool (Handshake13 -> IO ())+ -- The second bool is update transcript hash.+ PendingRecvAction Bool Bool (Handshake13 -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment.- PendingRecvActionHash Bool (ByteString -> Handshake13 -> IO ())+ PendingRecvActionHash Bool (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)@@ -291,7 +297,7 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx- let (ms, ems, cr, sr, hm13, grp) =+ let (ms, ems, cr, sr, hm13, grp, ech) = case hstate of Just st -> ( hstMainSecret st@@ -300,8 +306,9 @@ , hstServerRandom st , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing , hstSupportedGroup st+ , hstTLS13ECHAccepted st )- Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing)+ Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing, False) (cipher, comp) <- readMVar (ctxRxRecordState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of@@ -324,6 +331,7 @@ , infoTLS12Resumption = tls12resumption , infoTLS13HandshakeMode = hm13 , infoIsEarlyDataAccepted = accepted+ , infoIsECHAccepted = ech } _ -> return Nothing @@ -347,7 +355,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()-contextModifyHooks ctx = modifyIORef (ctxHooks ctx)+contextModifyHooks ctx = modifyIORef' (ctxHooks ctx) setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx)@@ -455,31 +463,16 @@ Left _ -> False Right v -> v >= TLS13 -addCertRequest13 :: Context -> Handshake13 -> IO ()-addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq :)--getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13)-getCertRequest13 ctx context = do- let ref = ctxCertRequests ctx- l <- readIORef ref- let (matched, others) = partition (\cr -> context == fromCertRequest13 cr) l- case matched of- [] -> return Nothing- (certReq : _) -> writeIORef ref others >> return (Just certReq)- where- fromCertRequest13 (CertRequest13 c _) = c- fromCertRequest13 _ = error "fromCertRequest13"- -------------------------------- setMyRecordLimit :: Context -> Maybe Int -> IO ()-setMyRecordLimit ctx msiz = modifyIORef (ctxMyRecordLimit ctx) change+setMyRecordLimit ctx msiz = modifyIORef' (ctxMyRecordLimit ctx) change where change (RecordLimit n _) = RecordLimit n msiz change x = x enableMyRecordLimit :: Context -> IO ()-enableMyRecordLimit ctx = modifyIORef (ctxMyRecordLimit ctx) change+enableMyRecordLimit ctx = modifyIORef' (ctxMyRecordLimit ctx) change where change (RecordLimit _ (Just n)) = RecordLimit n Nothing change x = x@@ -499,13 +492,13 @@ -------------------------------- setPeerRecordLimit :: Context -> Maybe Int -> IO ()-setPeerRecordLimit ctx msiz = modifyIORef (ctxPeerRecordLimit ctx) change+setPeerRecordLimit ctx msiz = modifyIORef' (ctxPeerRecordLimit ctx) change where change (RecordLimit n _) = RecordLimit n msiz change x = x enablePeerRecordLimit :: Context -> IO ()-enablePeerRecordLimit ctx = modifyIORef (ctxPeerRecordLimit ctx) change+enablePeerRecordLimit ctx = modifyIORef' (ctxPeerRecordLimit ctx) change where change (RecordLimit _ (Just n)) = RecordLimit n Nothing change x = x@@ -525,3 +518,11 @@ newRecordLimitRef :: Maybe Int -> IO (IORef RecordLimit) newRecordLimitRef Nothing = newIORef NoRecordLimit newRecordLimitRef (Just n) = newIORef $ RecordLimit n Nothing++--------------------------------++setTLS13HPKE :: Context -> HPKEF -> Int -> IO ()+setTLS13HPKE ctx func nenc = writeIORef (ctxHPKE ctx) $ Just (func, nenc)++getTLS13HPKE :: Context -> IO (Maybe (HPKEF, Int))+getTLS13HPKE ctx = readIORef $ ctxHPKE ctx
Network/TLS/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} @@ -34,19 +35,17 @@ import Data.IORef import System.Timeout -import Network.TLS.Cipher import Network.TLS.Context-import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Process+import Network.TLS.Handshake.Server import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports-import Network.TLS.KeySchedule import Network.TLS.Parameters import Network.TLS.PostHandshake import Network.TLS.Session@@ -55,8 +54,6 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (- AnyTrafficSecret (..),- ApplicationSecret, HostName, Role (..), )@@ -148,7 +145,7 @@ -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon.-getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)+getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -- | If the Server Name Indication extension has been used, return the@@ -196,7 +193,7 @@ -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF.-recvData :: MonadIO m => Context -> m B.ByteString+recvData :: MonadIO m => Context -> m ByteString recvData ctx = liftIO $ do tls13 <- tls13orLater ctx withReadLock ctx $ do@@ -210,7 +207,7 @@ -- will impact the validity of the context. if tls13 then recvData13 ctx else recvData12 ctx -recvData12 :: Context -> IO B.ByteString+recvData12 :: Context -> IO ByteString recvData12 ctx = do pkt <- recvPacket12 ctx either (onError terminate12) process pkt@@ -235,13 +232,13 @@ -- when receiving empty appdata, we just retry to get some data. process (AppData "") = recvData12 ctx process (AppData x) = return x- process p =+ process p = do let reason = "unexpected message " ++ show p- in terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) -recvData13 :: Context -> IO B.ByteString+recvData13 :: Context -> IO ByteString recvData13 ctx = do mdat <- tls13stPendingRecvData <$> getTLS13State ctx case mdat of@@ -283,9 +280,9 @@ | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x"- | otherwise ->+ | otherwise -> do let reason = "early data deprotect overflow"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do@@ -295,18 +292,18 @@ else do let reason = "CSS after Finished" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- process p =+ process p = do let reason = "unexpected message " ++ show p- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason 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 ticket exts : hs) = do+ loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do role <- usingState_ ctx S.getRole- unless (role == ClientRole) $+ unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager).@@ -359,18 +356,17 @@ else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- Client only loopHandshake13 (h@CertRequest13{} : hs) = postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h@Certificate13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h : hs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of- ServerHello13 srand _ _ _ ->- when (isHelloRetryRequest srand) $ do+ ServerHello13 SH{..} ->+ when (isHelloRetryRequest shRandom) $ do clearTxRecordState ctx let reason = "HRR is not allowed for 0-RTT"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return () cont <- popAction ctx h hs when cont $ loopHandshake13 hs@@ -393,11 +389,11 @@ 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 ticket exts : hs) = do+ loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do role <- usingState_ ctx S.getRole- unless (role == ClientRole) $+ unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"- in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager).@@ -439,14 +435,14 @@ withWriteLock ctx $ handleException ctx $ do case action of- PendingRecvAction needAligned pa -> do+ PendingRecvAction needAligned update pa -> do when needAligned $ checkAlignment ctx hs- processHandshake13 ctx h+ when update $ void $ updateTranscriptHash13 ctx h pa h PendingRecvActionHash needAligned pa -> do when needAligned $ checkAlignment ctx hs- d <- transcriptHash ctx- processHandshake13 ctx h+ d <- transcriptHash ctx "Pending action"+ void $ updateTranscriptHash13 ctx h pa d h -- Client: after receiving SH, app data is coming. -- this loop tries to receive it.@@ -469,15 +465,16 @@ onError :: Monad m- => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)+ => (TLSError -> AlertLevel -> AlertDescription -> String -> m ByteString) -> TLSError- -> m B.ByteString+ -> m ByteString onError _ Error_EOF = -- Not really an error. return B.empty-onError terminate err =- let (lvl, ad) = errorToAlert err- in terminate err lvl ad (errorToAlertMessage err)+onError terminate err = terminate err lvl ad reason+ where+ (lvl, ad) = errorToAlert err+ reason = errorToAlertMessage err terminateWithWriteLock :: Context@@ -502,6 +499,7 @@ sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx+ debugError (ctxDebug ctx) $ reason E.throwIO (Terminated False reason err) {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}@@ -509,45 +507,3 @@ -- | same as recvData but returns a lazy bytestring. recvData' :: MonadIO m => Context -> m L.ByteString recvData' ctx = L.fromChunks . (: []) <$> recvData ctx--keyUpdate- :: Context- -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))- -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())- -> IO ()-keyUpdate ctx getState setState = do- (usedHash, usedCipher, level, applicationSecretN) <- getState ctx- unless (level == CryptApplicationSecret) $- throwCore $- Error_Protocol- "tried key update without application traffic secret"- InternalError- let applicationSecretN1 =- hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $- hashDigestSize usedHash- setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)---- | How to update keys in TLS 1.3-data KeyUpdateRequest- = -- | Unidirectional key update- OneWay- | -- | Bidirectional key update (normal case)- TwoWay- deriving (Eq, Show)---- | Updating appication traffic secrets for TLS 1.3.--- If this API is called for TLS 1.3, 'True' is returned.--- Otherwise, 'False' is returned.-updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool-updateKey ctx way = liftIO $ do- tls13 <- tls13orLater ctx- when tls13 $ do- let req = case way of- OneWay -> UpdateNotRequested- TwoWay -> UpdateRequested- -- Write lock wraps both actions because we don't want another packet to- -- be sent by another thread before the Tx state is updated.- withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]- keyUpdate ctx getTxRecordState setTxRecordState- return tls13
Network/TLS/Credentials.hs view
@@ -17,14 +17,14 @@ ) where import Data.X509+import qualified Data.X509 as X509 import Data.X509.File import Data.X509.Memory+ import Network.TLS.Crypto import Network.TLS.Imports-import Network.TLS.X509--import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS+import Network.TLS.X509 type Credential = (CertificateChain, PrivKey)
Network/TLS/Crypto.hs view
@@ -15,6 +15,7 @@ -- * Hash hash,+ hashChunks, Hash (..), hashName, hashDigestSize,@@ -56,9 +57,12 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random+import Data.ASN1.BinaryEncoding (BER (..), DER (..))+import Data.ASN1.Encoding+import Data.ASN1.Types import qualified Data.ByteArray as B (convert) import qualified Data.ByteString as B-+import Data.Proxy import Data.X509 ( PrivKey (..), PrivKeyEC (..),@@ -67,17 +71,12 @@ SerializedPoint (..), ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint)+ import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types import Network.TLS.Imports -import Data.ASN1.BinaryEncoding (BER (..), DER (..))-import Data.ASN1.Encoding-import Data.ASN1.Types--import Data.Proxy- {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-}@@ -138,21 +137,29 @@ hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) hashInit SHA1_MD5 = HashContextSSL H.hashInit H.hashInit -hashUpdate :: HashContext -> B.ByteString -> HashCtx+hashUpdate :: HashContext -> ByteString -> HashCtx hashUpdate (HashContext (ContextSimple h)) b = HashContext $ ContextSimple (H.hashUpdate h b) hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) +hashUpdates :: HashContext -> [ByteString] -> HashCtx+hashUpdates (HashContext (ContextSimple h)) xs = HashContext $ ContextSimple (H.hashUpdates h xs)+hashUpdates (HashContextSSL sha1Ctx md5Ctx) xs =+ HashContextSSL (H.hashUpdates sha1Ctx xs) (H.hashUpdates md5Ctx xs)++hashChunks :: Hash -> [ByteString] -> ByteString+hashChunks h xs = hashFinal $ hashUpdates (hashInit h) xs+ hashUpdateSSL :: HashCtx- -> (B.ByteString, B.ByteString)+ -> (ByteString, ByteString) -- ^ (for the md5 context, for the sha1 context) -> HashCtx hashUpdateSSL (HashContext _) _ = error "internal error: update SSL without a SSL Context" hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1, b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) -hashFinal :: HashCtx -> B.ByteString+hashFinal :: HashCtx -> ByteString hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) = B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)]@@ -172,19 +179,19 @@ type HashCtx = HashContext -hash :: Hash -> B.ByteString -> B.ByteString-hash MD5 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.MD5) $ b-hash SHA1 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA1) $ b-hash SHA224 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA224) $ b-hash SHA256 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA256) $ b-hash SHA384 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA384) $ b-hash SHA512 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA512) $ b+hash :: Hash -> ByteString -> ByteString+hash MD5 b = B.convert . (H.hash :: ByteString -> H.Digest H.MD5) $ b+hash SHA1 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA1) $ b+hash SHA224 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA224) $ b+hash SHA256 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA256) $ b+hash SHA384 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA384) $ b+hash SHA512 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA512) $ b hash SHA1_MD5 b = B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)] where- sha1Hash :: B.ByteString -> H.Digest H.SHA1+ sha1Hash :: ByteString -> H.Digest H.SHA1 sha1Hash = H.hash- md5Hash :: B.ByteString -> H.Digest H.MD5+ md5Hash :: ByteString -> H.Digest H.MD5 md5Hash = H.hash hashName :: Hash -> String
Network/TLS/Crypto/DH.hs view
@@ -22,6 +22,7 @@ import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH import qualified Data.ByteArray as B+ import Network.TLS.RNG type DHPublic = DH.PublicNumber
Network/TLS/Crypto/IES.hs view
@@ -1,4 +1,5 @@--- |+-- | (Elliptic Curve) Integrated Encryption Scheme+-- -- Module : Network.TLS.Crypto.IES -- License : BSD-style -- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp>@@ -30,6 +31,7 @@ import Crypto.PubKey.ECIES import qualified Data.ByteArray as B import Data.Proxy+ import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE import Network.TLS.Imports
Network/TLS/Error.hs view
@@ -5,6 +5,7 @@ import Control.Exception (Exception (..)) import Data.Typeable+ import Network.TLS.Imports ----------------------------------------------------------------@@ -154,6 +155,8 @@ pattern GeneralError = AlertDescription 117 pattern NoApplicationProtocol :: AlertDescription pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301+pattern EchRequired :: AlertDescription+pattern EchRequired = AlertDescription 121 -- draft instance Show AlertDescription where show CloseNotify = "CloseNotify"@@ -190,5 +193,6 @@ show CertificateRequired = "CertificateRequired" show GeneralError = "GeneralError" show NoApplicationProtocol = "NoApplicationProtocol"+ show EchRequired = "EchRequired" show (AlertDescription x) = "AlertDescription " ++ show x {- FOURMOLU_ENABLE -}
Network/TLS/Extension.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-} -- | Basic extensions are defined in RFC 6066 module Network.TLS.Extension (@@ -44,6 +45,8 @@ EID_SignatureAlgorithmsCert, EID_KeyShare, EID_QuicTransportParameters,+ EID_EchOuterExtensions,+ EID_EncryptedClientHello, EID_SecureRenegotiation ), definedExtensions,@@ -100,13 +103,18 @@ EarlyDataIndication (..), Cookie (..), CertificateAuthorities (..),+ EchOuterExtensions (..),+ EncryptedClientHello (..), ) where import qualified Control.Exception as E+import Crypto.HPKE import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.X509 (DistinguishedName) +import Network.TLS.ECH.Config+ import Network.TLS.Crypto.Types import Network.TLS.Error import Network.TLS.HashAndSignature@@ -206,6 +214,10 @@ pattern EID_KeyShare = ExtensionID 0x33 pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001 pattern EID_QuicTransportParameters = ExtensionID 0x39+pattern EID_EchOuterExtensions :: ExtensionID -- draft+pattern EID_EchOuterExtensions = ExtensionID 0xfd00+pattern EID_EncryptedClientHello :: ExtensionID -- draft+pattern EID_EncryptedClientHello = ExtensionID 0xfe0d pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746 pattern EID_SecureRenegotiation = ExtensionID 0xff01 @@ -248,6 +260,8 @@ show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert" show EID_KeyShare = "KeyShare" show EID_QuicTransportParameters = "QuicTransportParameters"+ show EID_EchOuterExtensions = "EchOuterExtensions"+ show EID_EncryptedClientHello = "EncryptedClientHello" show EID_SecureRenegotiation = "SecureRenegotiation" show (ExtensionID x) = "ExtensionID " ++ show x {- FOURMOLU_ENABLE -}@@ -294,6 +308,8 @@ , EID_SignatureAlgorithmsCert , EID_KeyShare , EID_QuicTransportParameters+ , EID_EchOuterExtensions+ , EID_EncryptedClientHello , EID_SecureRenegotiation ] @@ -320,6 +336,8 @@ , EID_SignatureAlgorithmsCert -- 0x32 , EID_KeyShare -- 0x33 , EID_QuicTransportParameters -- 0x39+ , EID_EchOuterExtensions -- 0xfd00+ , EID_EncryptedClientHello -- 0xfe0d , EID_SecureRenegotiation -- 0xff01 ] {- FOURMOLU_ENABLE -}@@ -342,7 +360,7 @@ show (ExtensionRaw eid@EID_CompressCertificate bs) = showExtensionRaw eid bs decodeCompressCertificate show (ExtensionRaw eid@EID_RecordSizeLimit bs) = showExtensionRaw eid bs decodeRecordSizeLimit show (ExtensionRaw eid@EID_SessionTicket bs) = showExtensionRaw eid bs decodeSessionTicket- show (ExtensionRaw eid@EID_PreSharedKey bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid@EID_PreSharedKey bs) = showExtensionRaw eid bs decodePreSharedKey show (ExtensionRaw eid@EID_EarlyData _) = show eid show (ExtensionRaw eid@EID_SupportedVersions bs) = showExtensionRaw eid bs decodeSupportedVersions show (ExtensionRaw eid@EID_Cookie bs) = show eid ++ " " ++ showBytesHex bs@@ -351,6 +369,8 @@ show (ExtensionRaw eid@EID_PostHandshakeAuth _) = show eid show (ExtensionRaw eid@EID_SignatureAlgorithmsCert bs) = showExtensionRaw eid bs decodeSignatureAlgorithmsCert show (ExtensionRaw eid@EID_KeyShare bs) = showExtensionRaw eid bs decodeKeyShare+ show (ExtensionRaw eid@EID_EchOuterExtensions bs) = showExtensionRaw eid bs decodeEchOuterExtensions+ show (ExtensionRaw eid@EID_EncryptedClientHello bs) = showExtensionRaw eid bs decodeECH show (ExtensionRaw eid@EID_SecureRenegotiation bs) = show eid ++ " " ++ showBytesHex bs show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs @@ -736,13 +756,26 @@ ------------------------------------------------------------ -data PskIdentity = PskIdentity ByteString Word32 deriving (Eq, Show)+data PskIdentity = PskIdentity ByteString Word32 deriving (Eq) +instance Show PskIdentity where+ show (PskIdentity bs n) = "PskId " ++ showBytesHex bs ++ " " ++ show n+ data PreSharedKey = PreSharedKeyClientHello [PskIdentity] [ByteString] | PreSharedKeyServerHello Int- deriving (Eq, Show)+ deriving (Eq) +instance Show PreSharedKey where+ show (PreSharedKeyClientHello ids bndrs) =+ "PreSharedKey "+ ++ show ids+ ++ " "+ ++ "["+ ++ intercalate ", " (map showBytesHex bndrs)+ ++ "]"+ show (PreSharedKeyServerHello n) = "PreSharedKey " ++ show n+ instance Extension PreSharedKey where extensionID _ = EID_PreSharedKey extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do@@ -757,28 +790,39 @@ runPut $ putWord16 $ fromIntegral w16- extensionDecode MsgTServerHello =- runGetMaybe $- PreSharedKeyServerHello . fromIntegral <$> getWord16- extensionDecode MsgTClientHello = runGetMaybe $ do- len1 <- fromIntegral <$> getWord16- identities <- getList len1 getIdentity- len2 <- fromIntegral <$> getWord16- binders <- getList len2 getBinder- return $ PreSharedKeyClientHello identities binders- where- getIdentity = do- identity <- getOpaque16- age <- getWord32- let len = 2 + B.length identity + 4- return (len, PskIdentity identity age)- getBinder = do- l <- fromIntegral <$> getWord8- binder <- getBytes l- let len = l + 1- return (len, binder)+ extensionDecode MsgTClientHello = decodePreSharedKeyClientHello+ extensionDecode MsgTServerHello = decodePreSharedKeyServerHello extensionDecode _ = error "extensionDecode: PreShareKey" +decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyClientHello = runGetMaybe $ do+ len1 <- fromIntegral <$> getWord16+ identities <- getList len1 getIdentity+ len2 <- fromIntegral <$> getWord16+ binders <- getList len2 getBinder+ return $ PreSharedKeyClientHello identities binders+ where+ getIdentity = do+ identity <- getOpaque16+ age <- getWord32+ let len = 2 + B.length identity + 4+ return (len, PskIdentity identity age)+ getBinder = do+ l <- fromIntegral <$> getWord8+ binder <- getBytes l+ let len = l + 1+ return (len, binder)++decodePreSharedKeyServerHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyServerHello =+ runGetMaybe $+ PreSharedKeyServerHello . fromIntegral <$> getWord16++decodePreSharedKey :: ByteString -> Maybe PreSharedKey+decodePreSharedKey bs =+ decodePreSharedKeyClientHello bs+ <|> decodePreSharedKeyServerHello bs+ ------------------------------------------------------------ newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32)@@ -963,7 +1007,7 @@ instance Show KeyShare where show (KeyShareClientHello kses) = "KeyShare " ++ show kses show (KeyShareServerHello kse) = "KeyShare " ++ show kse- show (KeyShareHRR g) = "KeyShare " ++ show g+ show (KeyShareHRR g) = "KeyShareHRR " ++ show g {- FOURMOLU_ENABLE -} instance Extension KeyShare where@@ -1003,6 +1047,113 @@ decodeKeyShareClientHello bs <|> decodeKeyShareServerHello bs <|> decodeKeyShareHRR bs++------------------------------------------------------------++newtype EchOuterExtensions = EchOuterExtensions [ExtensionID]+ deriving (Eq, Show)++instance Extension EchOuterExtensions where+ extensionID _ = EID_EchOuterExtensions+ extensionEncode (EchOuterExtensions ids) = runPut $ do+ putWord8 $ fromIntegral (length ids * 2)+ mapM_ (putWord16 . fromExtensionID) ids+ extensionDecode MsgTClientHello = decodeEchOuterExtensions+ extensionDecode _ = error "extensionDecode: EchOuterExtensions"++decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions+decodeEchOuterExtensions = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ eids <- getList len $ do+ eid <- ExtensionID <$> getWord16+ return (2, eid)+ return $ EchOuterExtensions eids++------------------------------------------------------------++-- | Encrypted Client Hello+data EncryptedClientHello+ = ECHClientHelloInner+ | ECHClientHelloOuter+ { echCipherSuite :: (KDF_ID, AEAD_ID)+ , echConfigId :: ConfigId+ , echEnc :: EncodedPublicKey+ , echPayload :: ByteString+ }+ | ECHEncryptedExtensions ECHConfigList+ | ECHHelloRetryRequest ByteString+ deriving (Eq)++instance Show EncryptedClientHello where+ show ECHClientHelloInner = "ECHClientHelloInner"+ show ECHClientHelloOuter{..} =+ "ECHClientHelloOuter {"+ ++ show (fst echCipherSuite)+ ++ " "+ ++ show (snd echCipherSuite)+ ++ " "+ ++ show echConfigId+ ++ " "+ ++ showBytesHex enc+ ++ " "+ ++ showBytesHex echPayload+ ++ "}"+ where+ EncodedPublicKey enc = echEnc+ show (ECHEncryptedExtensions cnflst) = "ECHEncryptedExtensions " ++ show cnflst+ show (ECHHelloRetryRequest cnfm) = "ECHHelloRetryRequest " ++ showBytesHex cnfm++instance Extension EncryptedClientHello where+ extensionID _ = EID_EncryptedClientHello+ extensionEncode ECHClientHelloInner = runPut $ putWord8 1+ extensionEncode ECHClientHelloOuter{..} = runPut $ do+ putWord8 0+ let (kdfid, aeadid) = echCipherSuite+ putWord16 $ fromKDF_ID kdfid+ putWord16 $ fromAEAD_ID aeadid+ putWord8 echConfigId+ let EncodedPublicKey enc = echEnc+ putOpaque16 enc+ putOpaque16 echPayload+ extensionEncode (ECHEncryptedExtensions cnflist) = encodeECHConfigList cnflist+ extensionEncode (ECHHelloRetryRequest cnfm) = runPut $ putBytes cnfm+ extensionDecode MsgTClientHello = decodeECHClientHello+ extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions+ extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest+ extensionDecode _ = error "extensionDecode: EncryptedClientHello"++decodeECH :: ByteString -> Maybe EncryptedClientHello+decodeECH bs =+ decodeECHClientHello bs+ <|> decodeECHEncryptedExtensions bs+ <|> decodeECHHelloRetryRequest bs++decodeECHClientHello :: ByteString -> Maybe EncryptedClientHello+decodeECHClientHello = runGetMaybe $ do+ typ <- getWord8+ if typ == 1+ then return ECHClientHelloInner+ else do+ kdfid <- KDF_ID <$> getWord16+ aeadid <- AEAD_ID <$> getWord16+ cnfid <- getWord8+ enc <- EncodedPublicKey <$> getOpaque16+ payload <- getOpaque16+ return $+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfid+ , echEnc = enc+ , echPayload = payload+ }++decodeECHEncryptedExtensions :: ByteString -> Maybe EncryptedClientHello+decodeECHEncryptedExtensions bs =+ ECHEncryptedExtensions <$> decodeECHConfigList bs++decodeECHHelloRetryRequest :: ByteString -> Maybe EncryptedClientHello+decodeECHHelloRetryRequest = runGetMaybe $ do+ ECHHelloRetryRequest <$> getBytes 8 ------------------------------------------------------------
Network/TLS/Extra/Cipher.hs view
@@ -69,19 +69,19 @@ cipher_DHE_RSA_CHACHA20POLY1305_SHA256, ) where -import qualified Data.ByteString as B--import Data.Tuple (swap)-import Network.TLS.Cipher-import Network.TLS.Types- import Crypto.Cipher.AES import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.System.CPU+import qualified Data.ByteString as B+import Data.Tuple (swap) +import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types+ ---------------------------------------------------------------- -- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to@@ -680,7 +680,7 @@ ) simpleDecrypt- :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag)+ :: AEAD cipher -> ByteString -> ByteString -> Int -> (ByteString, AuthTag) simpleDecrypt aeadIni header input taglen = (output, tag) where aead = aeadAppendHeader aeadIni header
Network/TLS/Handshake.hs view
@@ -8,11 +8,10 @@ ) where import Network.TLS.Context.Internal-import Network.TLS.Struct- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.Struct import Control.Monad.State.Strict
Network/TLS/Handshake/Certificate.hs view
@@ -10,6 +10,7 @@ import Control.Monad (unless) import Control.Monad.State.Strict import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet)+ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509
Network/TLS/Handshake/Client.hs view
@@ -99,26 +99,6 @@ where groupToSend = listToMaybe groups -receiveServerHello- :: ClientParams- -> Context- -> Maybe (ClientRandom, Session, Version)- -> IO (Version, [Handshake], Bool)-receiveServerHello cparams ctx mparams = do- chSentTime <- getCurrentTimeFromBase- hss <- recvServerHello cparams ctx- setRTT ctx chSentTime- ver <- usingState_ ctx getVersion- unless (maybe True (\(_, _, v) -> v == ver) mparams) $- throwCore $- Error_Protocol "version changed after hello retry" IllegalParameter- -- recvServerHello sets TLS13HRR according to the server random.- -- For 1st server hello, getTLS13HR returns True if it is HRR and- -- False otherwise. For 2nd server hello, getTLS13HR returns- -- False since it is NOT HRR.- hrr <- usingState_ ctx getTLS13HRR- return (ver, hss, hrr)- ---------------------------------------------------------------- helloRetry
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -1,12 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo, ) where +import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as B+import Network.TLS.ECH.Config+import System.Random+ import Network.TLS.Cipher-import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension@@ -14,10 +20,10 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Packet hiding (getExtensions)@@ -36,7 +42,7 @@ -> PreSharedKeyInfo -> IO ClientRandom sendClientHello cparams ctx groups mparams pskinfo = do- crand <- generateClientHelloParams mparams+ crand <- generateClientHelloParams mparams -- Inner for ECH sendClientHello' cparams ctx groups crand pskinfo return crand where@@ -78,7 +84,10 @@ -> Context -> [Group] -> ClientRandom- -> PreSharedKeyInfo+ -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)+ , Maybe CipherChoice+ , Bool+ ) -> IO () sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer@@ -87,13 +96,54 @@ unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer let cipherIds = map (CipherId . cipherID) ciphers- compIds = map compressionID compressions- mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts- setMyRecordLimit ctx $ limitRecordSize $ sharedLimit $ clientShared cparams+ mkClientHello exts =+ CH+ { chVersion = ver+ , chRandom = crand+ , chSession = clientSession+ , chCiphers = cipherIds+ , chComps = [0]+ , chExtensions = exts+ }+ setMyRecordLimit ctx $ limitRecordSize $ sharedLimit $ ctxShared ctx extensions0 <- catMaybes <$> getExtensions let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0- extensions <- adjustExtentions extensions1 $ mkClientHello extensions1- sendPacket12 ctx $ Handshake [mkClientHello extensions]+ extensions <- adjustPreSharedKeyExt extensions1 $ mkClientHello extensions1+ let ch0 = mkClientHello extensions+ updateTranscriptHashI ctx "ClientHelloI" $ encodeHandshake $ ClientHello ch0+ let nhpks = supportedHPKE $ clientSupported cparams+ echcnfs = sharedECHConfigList $ clientShared cparams+ mEchParams = lookupECHConfigList nhpks echcnfs+ ch <-+ if clientUseECH cparams+ then case mEchParams of+ Nothing -> do+ if hrr+ then do+ chI <- fromJust <$> usingHState ctx getClientHello+ let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)}+ usingHState ctx $ setClientHello ch0'+ return ch0'+ else do+ gEchExt <- greasingEchExt+ let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)}+ usingHState ctx $ setClientHello ch0'+ return ch0'+ Just echParams -> do+ usingHState ctx $ setClientHello ch0+ mcrandO <- usingHState ctx getOuterClientRandom+ crandO <- case mcrandO of+ Nothing -> clientRandom ctx+ Just x -> return x+ usingHState ctx $ do+ setClientRandom crandO+ setOuterClientRandom $ Just crandO+ mpskExt <- randomPreSharedKeyExt+ createEncryptedClientHello ctx ch0 echParams crandO mpskExt+ else do+ usingHState ctx $ setClientHello ch0+ return ch0+ sendPacket12 ctx $ Handshake [ClientHello ch] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info@@ -102,7 +152,6 @@ modifyTLS13State ctx $ \st -> st{tls13stSentExtensions = sentExtensions} where ciphers = supportedCiphers $ ctxSupported ctx- compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx@@ -118,7 +167,8 @@ -- (not always present) have length > 0. getExtensions = sequence- [ {- 0x00 -} sniExt+ [ {- 0xfe0d -} echExt+ , {- 0x00 -} sniExt , {- 0x0a -} groupExt , {- 0x0b -} ecPointExt , {- 0x0d -} signatureAlgExt@@ -183,7 +233,7 @@ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib]) - recordSizeLimitExt = case limitRecordSize $ sharedLimit $ clientShared cparams of+ recordSizeLimitExt = case limitRecordSize $ sharedLimit $ ctxShared ctx of Nothing -> return Nothing Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz @@ -198,6 +248,13 @@ | otherwise = return Nothing versionExt+ | clientUseECH cparams = do+ let vers = supportedVersions $ ctxSupported ctx+ if TLS13 `elem` vers+ then+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello [TLS13]+ else+ throwCore $ Error_Misc "TLS 1.3 must be specified for Encrypted Client Hello" | tls13 = do let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers@@ -235,31 +292,52 @@ return $ Just $ toExtensionRaw $ SecureRenegotiation cvd "" else return Nothing + -- ECHClientHelloInner should be replaced if ECHConfigList is not available.+ echExt+ | clientUseECH cparams = return $ Just $ toExtensionRaw ECHClientHelloInner+ | otherwise = return Nothing+ preSharedKeyExt = case pskInfo of Nothing -> return Nothing- Just (identities, _, choice, obfAge) ->+ Just (identities, _, choice, obfAge) -> do let zero = cZero choice pskIdentities = map (\x -> PskIdentity x obfAge) identities -- [zero] is a place holds.- -- adjustExtentions will replace them.+ -- adjustPreSharedKeyExt will replace them. binders = replicate (length pskIdentities) zero offeredPsks = PreSharedKeyClientHello pskIdentities binders- in return $ Just $ toExtensionRaw offeredPsks+ return $ Just $ toExtensionRaw offeredPsks + randomPreSharedKeyExt :: IO (Maybe ExtensionRaw)+ randomPreSharedKeyExt =+ case pskInfo of+ Nothing -> return Nothing+ Just (identities, _, choice, _) -> do+ let zero = cZero choice+ zeroR <- getStdRandom $ uniformByteString $ B.length zero+ obfAgeR <- getStdRandom $ genWord32+ let genPskId x = do+ xR <- getStdRandom $ uniformByteString $ B.length x+ return $ PskIdentity xR obfAgeR+ pskIdentitiesR <- mapM genPskId identities+ let bindersR = replicate (length pskIdentitiesR) zeroR+ offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR+ return $ Just $ toExtensionRaw offeredPsksR+ ---------------------------------------- - adjustExtentions exts ch =+ adjustPreSharedKeyExt exts ch = case pskInfo of Nothing -> return exts Just (identities, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret- let ech = encodeHandshake ch+ let ech = encodeHandshake $ ClientHello ch h = cHash choice siz = (hashDigestSize h + 1) * length identities + 2- binder <- makePSKBinder ctx earlySecret h siz (Just ech)+ binder = makePSKBinder earlySecret h siz ech -- PSK is shared by the previous TLS session. -- So, PSK is unique for identities. let binders = replicate (length identities) binder@@ -273,9 +351,7 @@ let usedCipher = cCipher choice usedHash = cHash choice Just earlySecret <- usingHState ctx getTLS13EarlySecret- -- Client hello is stored in hstHandshakeDigest- -- But HandshakeDigestContext is not created yet.- earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False+ earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) let clientEarlySecret = pairClient earlyKey unless (ctxQUICMode ctx) $ do runPacketFlight ctx $ sendChangeCipherSpec13 ctx@@ -336,3 +412,162 @@ get0RTTinfo (_, sdata, choice, _) | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice | otherwise = Nothing++----------------------------------------------------------------++createEncryptedClientHello+ :: Context+ -> ClientHello+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> ClientRandom+ -> Maybe ExtensionRaw+ -> IO ClientHello+createEncryptedClientHello ctx ch0@CH{..} echParams@(kdfid, aeadid, conf) crO mpskExt = E.handle hpkeHandler $ do+ let (chExtsO, chExtsI) = dupCompExts (cnfPublicName conf) mpskExt chExtensions+ chI =+ ch0+ { chSession = Session Nothing+ , chExtensions = chExtsI+ }+ Just (func, enc, taglen) <- getHPKE ctx echParams+ let bsI = encodeHandshake' $ ClientHello chI+ padLen = 32 - (B.length bsI .&. 31)+ bsI' = bsI <> B.replicate padLen 0+ let outerZ =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = B.replicate (B.length bsI' + taglen) 0+ }+ echOZ = extensionEncode outerZ+ chExtsOTail = drop 1 chExtsO+ chOZ =+ ch0+ { chRandom = crO+ , chExtensions =+ ExtensionRaw EID_EncryptedClientHello echOZ : chExtsOTail+ }+ aad = encodeHandshake' $ ClientHello chOZ+ bsO <- func aad bsI'+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = bsO+ }+ echO = extensionEncode outer+ chO =+ chOZ+ { chExtensions =+ ExtensionRaw EID_EncryptedClientHello echO : chExtsOTail+ }+ return chO+ where+ hpkeHandler :: HPKEError -> IO ClientHello+ hpkeHandler _ = return ch0++dupCompExts+ :: HostName+ -> Maybe ExtensionRaw+ -> [ExtensionRaw]+ -> ([ExtensionRaw], [ExtensionRaw]) -- Outer, inner+dupCompExts host mpskExt chExts = step1 chExts+ where+ step1 (echExtI@(ExtensionRaw EID_EncryptedClientHello _) : exts) =+ (echExtO : os, echExtI : is)+ where+ echExtO = ExtensionRaw EID_EncryptedClientHello ""+ (os, is) = step2 exts+ step1 _ = error "step1"+ step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) =+ (sniExtO : os, sniExtI : is)+ where+ sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host]+ (os, is) = step3 exts id+ step2 _ = error "step2"+ step3 [] build = ([], [echOuterExt])+ where+ echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []+ step3 [pskExtI@(ExtensionRaw EID_PreSharedKey _)] build =+ ([pskExtO], [echOuterExt, pskExtI])+ where+ echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []+ pskExtO = fromJust mpskExt+ step3 (i@(ExtensionRaw eid _) : is) build = (i : os', is')+ where+ (os', is') = step3 is (build . (eid :))++getHPKE+ :: Context+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> IO (Maybe (AAD -> PlainText -> IO CipherText, EncodedPublicKey, Int))+getHPKE ctx (kdfid, aeadid, conf) = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let encodedConfig = encodeECHConfig conf+ info = "tls ech\x00" <> encodedConfig+ (pkSm, ctxS) <- setupBaseS kemid kdfid aeadid Nothing Nothing mpkR info+ let func = seal ctxS+ setTLS13HPKE ctx func 0+ return $ Just (func, pkSm, nT)+ Just (func, _) -> return $ Just (func, EncodedPublicKey "", nT)+ where+ mpkR = cnfEncodedPublicKey conf+ kemid = cnfKemId conf+ nT = nTag aeadid++----------------------------------------------------------------++lookupECHConfigList+ :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -> ECHConfigList+ -> Maybe (KDF_ID, AEAD_ID, ECHConfig)+lookupECHConfigList [] _ = Nothing+lookupECHConfigList ((kemid, kdfid, aeadid) : xs) cnfs =+ case find (\cnf -> cnfKemId cnf == kemid) cnfs of+ Nothing -> lookupECHConfigList xs cnfs+ Just cnf+ | (kdfid, aeadid) `elem` cnfCipherSuite cnf ->+ Just (kdfid, aeadid, cnf)+ | otherwise -> lookupECHConfigList xs cnfs++cnfKemId :: ECHConfig -> KEM_ID+cnfKemId ECHConfig{..} = KEM_ID $ kem_id $ key_config $ contents++cnfCipherSuite :: ECHConfig -> [(KDF_ID, AEAD_ID)]+cnfCipherSuite ECHConfig{..} = map conv $ cipher_suites $ key_config $ contents+ where+ conv HpkeSymmetricCipherSuite{..} = (KDF_ID kdf_id, AEAD_ID aead_id)++cnfEncodedPublicKey :: ECHConfig -> EncodedPublicKey+cnfEncodedPublicKey ECHConfig{..} = EncodedPublicKey pk+ where+ EncodedServerPublicKey pk = public_key $ key_config contents++cnfPublicName :: ECHConfig -> HostName+cnfPublicName ECHConfig{..} = public_name contents++cnfConfigId :: ECHConfig -> ConfigId+cnfConfigId ECHConfig{..} = config_id $ key_config contents++----------------------------------------------------------------++-- Pretending X25519 is used because it is the de-facto and+-- its public key is easily created.+greasingEchExt :: IO ExtensionRaw+greasingEchExt = do+ cid <- getStdRandom genWord8+ enc <- getStdRandom $ uniformByteString 32+ n <- getStdRandom $ randomR (4, 6)+ payload <- getStdRandom $ uniformByteString (n * 32 + 16)+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (HKDF_SHA256, AES_128_GCM)+ , echConfigId = cid+ , echEnc = EncodedPublicKey enc+ , echPayload = payload+ }+ return $ toExtensionRaw outer
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ServerHello (- recvServerHello,+ receiveServerHello, processServerHello13, ) where +import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -12,13 +15,14 @@ import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -27,13 +31,27 @@ ---------------------------------------------------------------- -recvServerHello- :: ClientParams -> Context -> IO [Handshake]-recvServerHello cparams ctx = do+receiveServerHello+ :: ClientParams+ -> Context+ -> Maybe (ClientRandom, Session, Version)+ -> IO (Version, [Handshake], Bool)+receiveServerHello cparams ctx mparams = do+ chSentTime <- getCurrentTimeFromBase (sh, hss) <- recvSH processServerHello cparams ctx sh- processHandshake12 ctx sh- return hss+ void $ updateTranscriptHash12 ctx sh+ setRTT ctx chSentTime+ ver <- usingState_ ctx getVersion+ unless (maybe True (\(_, _, v) -> v == ver) mparams) $+ throwCore $+ Error_Protocol "version changed after hello retry" IllegalParameter+ -- recvServerHello sets TLS13HRR according to the server random.+ -- For 1st server hello, getTLS13HR returns True if it is HRR and+ -- False otherwise. For 2nd server hello, getTLS13HR returns+ -- False since it is NOT HRR.+ hrr <- usingState_ ctx getTLS13HRR+ return (ver, hss, hrr) where recvSH = do epkt <- recvPacket12 ctx@@ -53,51 +71,55 @@ processServerHello13 :: ClientParams -> Context -> Handshake13 -> IO ()-processServerHello13 cparams ctx (ServerHello13 serverRan serverSession cipher shExts) = do- let sh = ServerHello TLS12 serverRan serverSession cipher 0 shExts- processServerHello cparams ctx sh+processServerHello13 cparams ctx (ServerHello13 sh13) = do+ let sh12 = ServerHello sh13+ processServerHello cparams ctx sh12 processServerHello13 _ _ h = unexpected (show h) (Just "server hello") -- | processServerHello processes the ServerHello message on the client. ----- 1) check the version chosen by the server is one allowed by parameters.--- 2) check that our compression and cipher algorithms are part of the list we sent+-- 1) check the version chosen by the server is one allowed by+-- parameters.+-- 2) check that our compression and cipher algorithms are part of the+-- list we sent -- 3) check extensions received are part of the one we sent--- 4) process the session parameter to see if the server want to start a new session or can resume+-- 4) process the session parameter to see if the server want to start+-- a new session or can resume processServerHello :: ClientParams -> Context -> Handshake -> IO ()-processServerHello cparams ctx (ServerHello rver serverRan serverSession (CipherId cid) compression shExts) = do+processServerHello cparams ctx (ServerHello sh@SH{..}) = do -- A server which receives a legacy_version value not equal to -- 0x0303 MUST abort the handshake with an "illegal_parameter" -- alert.- when (rver /= TLS12) $+ when (shVersion /= TLS12) $ throwCore $- Error_Protocol (show rver ++ " is not supported") IllegalParameter+ Error_Protocol (show shVersion ++ " is not supported") IllegalParameter -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx chExts <- tls13stSentExtensions <$> getTLS13State ctx let clientCiphers = supportedCiphers $ ctxSupported ctx- cipherAlg <- case findCipher cid clientCiphers of+ usedCipher <- case findCipher (fromCipherId shCipher) clientCiphers of Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter Just alg -> return alg compressAlg <- case find- ((==) compression . compressionID)+ ((==) shComp . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter Just alg -> return alg- ensureNullCompression compression+ ensureNullCompression shComp - -- intersect sent extensions in client and the received extensions from server.- -- if server returns extensions that we didn't request, fail.+ -- intersect sent extensions in client and the received extensions+ -- from server. if server returns extensions that we didn't+ -- request, fail. let checkExt (ExtensionRaw i _) | i == EID_Cookie = False -- for HRR | otherwise = i `notElem` chExts- when (any checkExt shExts) $+ when (any checkExt shExtensions) $ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension - let isHRR = isHelloRetryRequest serverRan+ let isHRR = isHelloRetryRequest shRandom usingState_ ctx $ do setTLS13HRR isHRR when isHRR $@@ -105,24 +127,24 @@ lookupAndDecode EID_Cookie MsgTServerHello- shExts+ shExtensions Nothing (\cookie@(Cookie _) -> Just cookie)- setVersion rver -- must be before processing supportedVersions ext- mapM_ processServerExtension shExts+ setVersion shVersion -- must be before processing supportedVersions ext+ mapM_ processServerExtension shExtensions - setALPN ctx MsgTServerHello shExts+ setALPN ctx MsgTServerHello shExtensions ver <- usingState_ ctx getVersion - when (ver == TLS12) $ do- usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg+ when (ver == TLS12) $+ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg let supportedVers = supportedVersions $ clientSupported cparams when (ver == TLS13) $ do -- TLS 1.3 server MUST echo the session id- when (clientSession /= serverSession) $+ when (clientSession /= shSession) $ throwCore $ Error_Protocol "session is not matched in compatibility mode"@@ -133,37 +155,48 @@ ("server version " ++ show ver ++ " is not supported") ProtocolVersion - -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3- -- in the supported_versions extension, *AND ALSO* set the TLS 1.2- -- downgrade signal in the server random. If we support TLS 1.3 and- -- actually negotiate TLS 1.3, we must ignore the server random downgrade- -- signal. Therefore, 'isDowngraded' needs to take into account the- -- negotiated version and the server random, as well as the list of- -- client-side enabled protocol versions.+ -- Some servers set TLS 1.2 as the legacy server hello version,+ -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set+ -- the TLS 1.2 downgrade signal in the server random. If we+ -- support TLS 1.3 and actually negotiate TLS 1.3, we must ignore+ -- the server random downgrade signal. Therefore, 'isDowngraded'+ -- needs to take into account the negotiated version and the+ -- server random, as well as the list of client-side enabled+ -- protocol versions. --- when (isDowngraded ver supportedVers serverRan) $+ when (isDowngraded ver supportedVers shRandom) $ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter if ver == TLS13 then do -- Session is dummy in TLS 1.3.- usingState_ ctx $ setSession serverSession- processRecordSizeLimit cparams ctx shExts True+ usingState_ ctx $ setSession shSession+ processRecordSizeLimit ctx shExtensions True enableMyRecordLimit ctx enablePeerRecordLimit ctx- updateContext13 ctx cipherAlg+ let usedHash = cipherHash usedCipher+ transitTranscriptHashI ctx "transitI" usedHash isHRR+ accepted <- checkECHacceptance ctx isHRR usedHash sh+ when accepted $ do+ CH{..} <- fromJust <$> usingHState ctx getClientHello+ usingHState ctx $ setClientRandom chRandom -- inner random+ when (accepted && not isHRR) $ do+ copyTranscriptHash ctx "copy"+ usingHState ctx $ setECHAccepted True+ updateContext13 ctx usedCipher isHRR+ updateTranscriptHashI ctx "ServerHelloI" $ encodeHandshake $ ServerHello sh else do let resumingSession = case clientSessions cparams of (_, sessionData) : _ ->- if serverSession == clientSession then Just sessionData else Nothing+ if shSession == clientSession then Just sessionData else Nothing _ -> Nothing usingState_ ctx $ do- setSession serverSession+ setSession shSession setTLS12SessionResuming $ isJust resumingSession- processRecordSizeLimit cparams ctx shExts False- updateContext12 ctx shExts resumingSession+ processRecordSizeLimit ctx shExtensions False+ updateContext12 ctx shExtensions resumingSession processServerHello _ _ p = unexpected (show p) (Just "server hello") ----------------------------------------------------------------@@ -191,8 +224,8 @@ ---------------------------------------------------------------- -updateContext13 :: Context -> Cipher -> IO ()-updateContext13 ctx cipherAlg = do+updateContext13 :: Context -> Cipher -> Bool -> IO ()+updateContext13 ctx usedCipher isHRR = do established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $@@ -200,11 +233,11 @@ Error_Protocol "renegotiation to TLS 1.3 or later is not allowed" ProtocolVersion- failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher isHRR updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()-updateContext12 ctx shExts resumingSession = do- ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExts+updateContext12 ctx shExtensions resumingSession = do+ ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExtensions case resumingSession of Nothing -> return () Just sessionData -> do@@ -219,16 +252,16 @@ ---------------------------------------------------------------- processRecordSizeLimit- :: ClientParams -> Context -> [ExtensionRaw] -> Bool -> IO ()-processRecordSizeLimit cparams ctx shExts tls13 = do- let mmylim = limitRecordSize $ sharedLimit $ clientShared cparams+ :: Context -> [ExtensionRaw] -> Bool -> IO ()+processRecordSizeLimit ctx shExtensions tls13 = do+ let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx case mmylim of Nothing -> return () Just mylim -> do lookupAndDecodeAndDo EID_RecordSizeLimit MsgTClientHello- shExts+ shExtensions (return ()) (setPeerRecordSizeLimit ctx tls13) ack <- checkPeerRecordLimit ctx@@ -239,3 +272,34 @@ -- RecordSizeLimit to RecordLimit, we should reduce the -- value by 1, which is the length of CT:. when (ack && tls13) $ setMyRecordLimit ctx $ Just (mylim - 1)++----------------------------------------------------------------++checkECHacceptance :: Context -> Bool -> Hash -> ServerHello -> IO Bool+checkECHacceptance ctx False usedHash sh@SH{..} = do+ let (prefix, confirm) = B.splitAt 24 $ unServerRandom shRandom+ sr' = ServerRandom (prefix <> "\x00\x00\x00\x00\x00\x00\x00\x00")+ verified <-+ computeConfirm ctx usedHash sh{shRandom = sr'} "ech accept confirmation"+ return (confirm == verified)+checkECHacceptance ctx True usedHash sh@SH{..} = do+ case replace shExtensions of+ Nothing -> return False+ Just (confirm, shExts') -> do+ verified <-+ computeConfirm+ ctx+ usedHash+ sh{shExtensions = shExts'}+ "hrr ech accept confirmation"+ return (confirm == verified)+ where+ replace [] = Nothing+ replace (ExtensionRaw EID_EncryptedClientHello confirm : es) =+ Just+ ( confirm+ , ExtensionRaw EID_EncryptedClientHello "\x00\x00\x00\x00\x00\x00\x00\x00" : es+ )+ replace (e : es) = case replace es of+ Nothing -> Nothing+ Just (confirm, es') -> Just (confirm, e : es')
Network/TLS/Handshake/Client/TLS12.hs view
@@ -42,7 +42,7 @@ runRecvStateHS ctx st hs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)-expectCertificate cparams ctx (Certificate (TLSCertificateChain certs)) = do+expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do usingState_ ctx $ setServerCertificateChain certs doCertificate cparams ctx certs processCertificate ctx ClientRole certs@@ -95,7 +95,7 @@ (sharedSessionManager $ ctxShared ctx) identity (fromJust sessionData)- handshakeDone12 ctx+ finishHandshake12 ctx liftIO $ do minfo <- contextGetInformation ctx case minfo of@@ -151,7 +151,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True- sendPacket12 ctx $ Handshake [Certificate (TLSCertificateChain cc)]+ sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] ----------------------------------------------------------------
Network/TLS/Handshake/Client/TLS13.hs view
@@ -15,6 +15,7 @@ import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Error import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello@@ -22,10 +23,10 @@ import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters@@ -44,7 +45,7 @@ runRecvHandshake13 $ do recvHandshake13 ctx $ expectEncryptedExtensions ctx unless resuming $ recvHandshake13 ctx $ expectCertRequest cparams ctx- recvHandshake13hash ctx $ expectFinished cparams ctx+ recvHandshake13hash ctx "Finished" $ expectFinished cparams ctx ---------------------------------------------------------------- @@ -211,8 +212,8 @@ -- not used in 0-RTT expectCertAndVerify :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()-expectCertAndVerify cparams ctx (Certificate13 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc-expectCertAndVerify cparams ctx (CompressedCertificate13 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate") processCertAndVerify@@ -225,13 +226,13 @@ ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey- recvHandshake13hash ctx $ expectCertVerify ctx pubkey+ recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey ---------------------------------------------------------------- expectCertVerify- :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m ()-expectCertVerify ctx pubkey hChSc (CertVerify13 (DigitallySigned sigAlg sig)) = do+ :: MonadIO m => Context -> PubKey -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify")@@ -242,7 +243,7 @@ :: MonadIO m => ClientParams -> Context- -> ByteString+ -> TranscriptHash -> Handshake13 -> m () expectFinished cparams ctx hashValue (Finished13 verifyData) = do@@ -270,6 +271,10 @@ eexts = tls13stClientExtensions st sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts modifyTLS13State ctx $ \s -> s{tls13stSentCF = True}+ echAccepted <- usingHState ctx getECHAccepted+ when (clientUseECH cparams && not echAccepted) $+ throwCore $+ Error_Protocol "ECH is not accepted" EchRequired sendClientSecondFlight13' :: ClientParams@@ -280,7 +285,7 @@ -> [ExtensionRaw] -> IO () sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" unless (ctxQUICMode ctx) $ runPacketFlight ctx $ sendChangeCipherSpec13 ctx@@ -295,7 +300,7 @@ let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) contextSync ctx $ SendClientFinished eexts appSecInfo modifyTLS13State ctx $ \st -> st{tls13stHsKey = Nothing}- handshakeDone13 ctx+ finishHandshake13 ctx rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ do builder <- tls13stPendingSentData <$> getTLS13State ctx@@ -350,11 +355,11 @@ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx let certtag = if certComp then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [certtag token (TLSCertificateChain chain) certExts]+ Handshake13 [certtag token (CertificateChain_ chain) certExts] case certs of [] -> return () _ -> do- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubKey <- getLocalPublicKey ctx sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey@@ -371,7 +376,7 @@ postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- processHandshake13 ctx h+ void $ updateTranscriptHash13 ctx h processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $@@ -398,14 +403,15 @@ asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx- [ PendingRecvAction True expectServerHello- , PendingRecvAction True (expectEncryptedExtensions ctx)+ [ PendingRecvAction True False expectServerHello+ , PendingRecvAction True True (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] where expectServerHello sh = do setRTT ctx chSentTime processServerHello13 cparams ctx sh+ void $ updateTranscriptHash13 ctx sh -- update by myself void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do expectFinished cparams ctx h sf
Network/TLS/Handshake/Common.hs view
@@ -6,7 +6,6 @@ handleException, unexpected, newSession,- handshakeDone12, ensureNullCompression, ticketOrSessionID12, @@ -31,6 +30,12 @@ processCertificate, -- setPeerRecordSizeLimit,+ generateFinished,+ updateTranscriptHash12,+ --+ startHandshake,+ finishHandshake12,+ setServerHelloParameters12, ) where import Control.Concurrent.MVar@@ -44,13 +49,15 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -64,6 +71,7 @@ handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do+ debugError (ctxDebug ctx) $ show exception -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed.@@ -114,26 +122,6 @@ | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing --- | when a new handshake is done, wrap up & clean up.-handshakeDone12 :: Context -> IO ()-handshakeDone12 ctx = do- -- forget most handshake data and reset bytes counters.- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstExtendedMainSecret = hstExtendedMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- }- updateMeasure ctx resetBytesCounters- -- mark the secure connection up and running.- setEstablished ctx Established- return ()- sendCCSandFinished :: Context -> Role@@ -142,10 +130,8 @@ sendPacket12 ctx ChangeCipherSpec contextFlush ctx enablePeerRecordLimit ctx- verifyData <-- VerifyData- <$> ( usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role- )+ ver <- usingState_ ctx getVersion+ verifyData <- VerifyData <$> (generateFinished ctx ver role) sendPacket12 ctx (Handshake [Finished verifyData]) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx@@ -180,9 +166,9 @@ onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms) onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do let finished = isFinished x- unless finished $ processHandshake12 ctx x+ unless finished $ void $ updateTranscriptHash12 ctx x nstate <- f x- when finished $ processHandshake12 ctx x+ when finished $ void $ updateTranscriptHash12 ctx x onRecvStateHandshake ctx nstate xs onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing @@ -310,9 +296,8 @@ processFinished :: Context -> VerifyData -> IO () processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion- expected <-- VerifyData <$> usingHState ctx (getHandshakeDigest ver $ invertRole cc)- when (expected /= verifyData) $ decryptError "cannot verify finished"+ expected <- VerifyData <$> generateFinished ctx ver (invertRole cc)+ when (expected /= verifyData) $ decryptError "finished verification failed" usingState_ ctx $ setVerifyDataForRecv verifyData processCertificate :: Context -> Role -> CertificateChain -> IO ()@@ -358,3 +343,95 @@ protolim | tls13 = defaultRecordSizeLimit + 1 | otherwise = defaultRecordSizeLimit++----------------------------------------------------------------++generateFinished :: Context -> Version -> Role -> IO ByteString+generateFinished ctx ver role = do+ thash <- transcriptHash ctx "generateFinished"+ (mainSecret, cipher) <- usingHState ctx $ gets $ \hst ->+ (fromJust $ hstMainSecret hst, fromJust $ hstPendingCipher hst)+ return $+ if role == ClientRole+ then+ generateClientFinished ver cipher mainSecret thash+ else+ generateServerFinished ver cipher mainSecret thash++generateFinished'+ :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString+generateFinished' prf label mainSecret (TranscriptHash thash) = prf mainSecret seed 12+ where+ seed = label <> thash++generateClientFinished+ :: Version+ -> Cipher+ -> ByteString+ -> TranscriptHash+ -> ByteString+generateClientFinished ver ciph =+ generateFinished' (getPRF ver ciph) "client finished"++generateServerFinished+ :: Version+ -> Cipher+ -> ByteString+ -> TranscriptHash+ -> ByteString+generateServerFinished ver ciph =+ generateFinished' (getPRF ver ciph) "server finished"++----------------------------------------------------------------++-- initialize a new Handshake context (initial handshake or renegotiations)+startHandshake :: Context -> Version -> ClientRandom -> IO ()+startHandshake ctx ver crand =+ void $ swapMVar (ctxHandshakeState ctx) $ Just hs+ where+ hs = newEmptyHandshake ver crand++setServerHelloParameters12+ :: Context+ -> Version+ -- ^ chosen version+ -> ServerRandom+ -> Cipher+ -> Compression+ -> IO ()+setServerHelloParameters12 ctx ver sran cipher compression = do+ usingHState ctx $+ modify' $ \hst ->+ hst+ { hstServerRandom = Just sran+ , hstPendingCipher = Just cipher+ , hstPendingCompression = compression+ }+ transitTranscriptHash ctx "transit" (getHash ver cipher) False++-- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384+-- instead of the default SHA256.+getHash :: Version -> Cipher -> Hash+getHash ver ciph+ | ver < TLS12 = SHA1_MD5+ | maybe True (< TLS12) (cipherMinVer ciph) = SHA256+ | otherwise = cipherHash ciph++-- | when a new handshake is done, wrap up & clean up.+finishHandshake12 :: Context -> IO ()+finishHandshake12 ctx = do+ -- forget most handshake data and reset bytes counters.+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstExtendedMainSecret = hstExtendedMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ }+ updateMeasure ctx resetBytesCounters+ -- mark the secure connection up and running.+ setEstablished ctx Established
Network/TLS/Handshake/Common13.hs view
@@ -14,7 +14,6 @@ makePSKBinder, replacePSKBinder, sendChangeCipherSpec13,- handshakeDone13, makeCertRequest, createTLS13TicketInfo, ageToObfuscatedAge,@@ -39,8 +38,14 @@ derivePSK, checkKeyShareKeyLength, setRTT,+ computeConfirm,+ updateTranscriptHash13,+ setServerHelloParameters13,+ finishHandshake13, ) where +import Control.Concurrent.MVar+import Control.Monad.State.Strict import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.UnixTime@@ -50,18 +55,21 @@ import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES +import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process (processHandshake13) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC+import Network.TLS.Packet+import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -69,30 +77,30 @@ import Network.TLS.Types import Network.TLS.Wire -import Control.Concurrent.MVar-import Control.Monad.State.Strict- ---------------------------------------------------------------- makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 makeFinished ctx usedHash baseKey = do verifyData <-- VerifyData . makeVerifyData usedHash baseKey <$> transcriptHash ctx+ VerifyData . makeVerifyData usedHash baseKey+ <$> transcriptHash ctx "makeFinished" liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData pure $ Finished13 verifyData checkFinished- :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> VerifyData -> m ()-checkFinished ctx usedHash baseKey hashValue vd@(VerifyData verifyData) = do- let verifyData' = makeVerifyData usedHash baseKey hashValue+ :: MonadIO m+ => Context -> Hash -> ByteString -> TranscriptHash -> VerifyData -> m ()+checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do+ let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol "broken Finished" DecodeError- unless (verifyData' == verifyData) $ decryptError "cannot verify finished"+ unless (verifyData' == verifyData) $ decryptError "finished verification failed" liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString-makeVerifyData usedHash baseKey = hmac usedHash finishedKey+makeVerifyData :: Hash -> ByteString -> TranscriptHash -> ByteString+makeVerifyData usedHash baseKey (TranscriptHash th) =+ hmac usedHash finishedKey th where hashSize = hashDigestSize usedHash finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize@@ -145,9 +153,9 @@ => Context -> PubKey -> HashAndSignatureAlgorithm- -> ByteString+ -> TranscriptHash -> m Handshake13-makeCertVerify ctx pub hs hashValue = do+makeCertVerify ctx pub hs (TranscriptHash hashValue) = do role <- liftIO $ usingState_ ctx getRole let ctxStr | role == ClientRole = clientContextString@@ -198,22 +206,18 @@ ---------------------------------------------------------------- makePSKBinder- :: Context- -> BaseSecret EarlySecret+ :: BaseSecret EarlySecret -> Hash -> Int- -> Maybe ByteString- -> IO ByteString-makePSKBinder ctx (BaseSecret sec) usedHash truncLen mch = do- rmsgs <- case mch of- Just ch -> (trunc ch :) <$> usingHState ctx getHandshakeMessagesRev- Nothing -> do- ch : rs <- usingHState ctx getHandshakeMessagesRev- return $ trunc ch : rs- let hChTruncated = hash usedHash $ B.concat $ reverse rmsgs- binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "")- return $ makeVerifyData usedHash binderKey hChTruncated+ -> ByteString+ -- ^ Encoded client hello+ -> ByteString+makePSKBinder (BaseSecret sec) usedHash truncLen ech =+ makeVerifyData usedHash binderKey hChTruncated where+ hChTruncated = TranscriptHash $ hash usedHash $ trunc ech+ th = TranscriptHash $ hash usedHash ""+ binderKey = deriveSecret usedHash sec "res binder" th trunc x = B.take takeLen x where totalLen = B.length x@@ -239,37 +243,6 @@ ---------------------------------------------------------------- --- | TLS13 handshake wrap up & clean up. Contrary to @handshakeDone@, this--- does not handle session, which is managed separately for TLS 1.3. This does--- not reset byte counters because renegotiation is not allowed. And a few more--- state attributes are preserved, necessary for TLS13 handshake modes, session--- tickets and post-handshake authentication.-handshakeDone13 :: Context -> IO ()-handshakeDone13 ctx = do- -- forget most handshake data- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- , hstHandshakeDigest = hstHandshakeDigest hshake- , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake- , hstTLS13RTT0Status = hstTLS13RTT0Status hshake- , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake- }- -- forget handshake data stored in TLS state- usingState_ ctx $ do- setTLS13KeyShare Nothing- setTLS13PreSharedKey Nothing- -- mark the secure connection up and running.- setEstablished ctx Established------------------------------------------------------------------- makeCertRequest :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13 makeCertRequest sparams ctx certReqCtx zlib =@@ -413,10 +386,11 @@ recvHandshake13hash :: MonadIO m => Context- -> (ByteString -> Handshake13 -> RecvHandshake13M m a)+ -> String+ -> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13hash ctx f = do- d <- transcriptHash ctx+recvHandshake13hash ctx label f = do+ d <- transcriptHash ctx label getHandshake13 ctx >>= f d getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13@@ -426,7 +400,7 @@ (h : hs) -> found h hs [] -> recvLoop where- found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h+ found h hs = liftIO (void $ updateTranscriptHash13 ctx h) >> put hs >> return h recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of@@ -486,15 +460,10 @@ :: Context -> CipherChoice -> Either ByteString (BaseSecret EarlySecret)- -> Bool -> IO (SecretPair EarlySecret)-calculateEarlySecret ctx choice maux initialized = do- hCh <-- if initialized- then transcriptHash ctx- else do- hmsgs <- usingHState ctx getHandshakeMessages- return $ hash usedHash $ B.concat hmsgs+calculateEarlySecret ctx choice maux = do+ ch <- fromJust <$> usingHState ctx getClientHello+ let hCh = TranscriptHash $ hash usedHash $ encodeHandshake $ ClientHello ch let earlySecret = case maux of Right (BaseSecret sec) -> sec Left psk -> hkdfExtract usedHash zero psk@@ -521,11 +490,12 @@ -> ByteString -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do- hChSh <- transcriptHash ctx- let handshakeSecret =+ hChSh <- transcriptHash ctx "CH..SH"+ let th = TranscriptHash $ hash usedHash ""+ handshakeSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) ecdhe let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh@@ -543,13 +513,14 @@ :: Context -> CipherChoice -> BaseSecret HandshakeSecret- -> ByteString+ -> TranscriptHash -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do- let applicationSecret =+ let th = TranscriptHash $ hash usedHash ""+ applicationSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf@@ -574,15 +545,15 @@ -> BaseSecret ApplicationSecret -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do- hChCf <- transcriptHash ctx+ hChCf <- transcriptHash ctx "CH..CF" let resumptionSecret = deriveSecret usedHash sec "res master" hChCf return $ BaseSecret resumptionSecret where usedHash = cHash choice derivePSK- :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString-derivePSK choice (BaseSecret sec) nonce =+ :: CipherChoice -> BaseSecret ResumptionSecret -> TicketNonce -> ByteString+derivePSK choice (BaseSecret sec) (TicketNonce nonce) = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where usedHash = cHash choice@@ -615,3 +586,67 @@ let rtt' = shRecvTime - chSentTime rtt = if rtt' == 0 then 10 else rtt' modifyTLS13State ctx $ \st -> st{tls13stRTT = rtt}++computeConfirm+ :: (MonadFail m, MonadIO m)+ => Context -> Hash -> ServerHello -> ByteString -> m ByteString+computeConfirm ctx usedHash sh label = do+ CH{..} <- fromJust <$> liftIO (usingHState ctx getClientHello)+ TranscriptHash echConf <-+ transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh+ let prk = hkdfExtract usedHash "" $ unClientRandom chRandom+ return $ hkdfExpandLabel usedHash prk label echConf 8++----------------------------------------------------------------++setServerHelloParameters13+ :: Context -> Cipher -> Bool -> IO (Either TLSError ())+setServerHelloParameters13 ctx cipher isHRR = do+ transitTranscriptHash ctx "transit" (cipherHash cipher) isHRR+ usingHState ctx $ do+ hst <- get+ case hstPendingCipher hst of+ Nothing -> do+ put+ hst+ { hstPendingCipher = Just cipher+ , hstPendingCompression = nullCompression+ }+ return $ Right ()+ Just oldcipher+ | cipher == oldcipher -> return $ Right ()+ | otherwise ->+ return $+ Left $+ Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter++-- | TLS13 handshake wrap up & clean up. Contrary to+-- @finishHandshake12@, this does not handle session, which is managed+-- separately for TLS 1.3. This does not reset byte counters because+-- renegotiation is not allowed. And a few more state attributes are+-- preserved, necessary for TLS13 handshake modes, session tickets and+-- post-handshake authentication.+finishHandshake13 :: Context -> IO ()+finishHandshake13 ctx = do+ -- forget most handshake data+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ , hstTransHashState = hstTransHashState hshake+ , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake+ , hstTLS13RTT0Status = hstTLS13RTT0Status hshake+ , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake+ , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake+ }+ -- forget handshake data stored in TLS state+ usingState_ ctx $ do+ setTLS13KeyShare Nothing+ setTLS13PreSharedKey Nothing+ -- mark the secure connection up and running.+ setEstablished ctx Established
Network/TLS/Handshake/Key.hs view
@@ -20,13 +20,13 @@ ) where import Control.Monad.State.Strict- import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Handshake.State import Network.TLS.Imports+import Network.TLS.Parameters import Network.TLS.State (withRNG) import Network.TLS.Struct import Network.TLS.Types@@ -172,8 +172,9 @@ case mhst of Nothing -> return () Just hst -> do- let cr = unClientRandom $ hstClientRandom hst+ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst)+ cr = unClientRandom crm (label, key) = labelAndKey logkey- ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key+ debugKeyLogger (ctxDebug ctx) $ label ++ " " ++ dump cr ++ " " ++ dump key where dump = init . drop 1 . showBytesHex
− Network/TLS/Handshake/Process.hs
@@ -1,34 +0,0 @@--- |--- process handshake message received-module Network.TLS.Handshake.Process (- processHandshake12,- processHandshake13,- startHandshake,-) where--import Control.Concurrent.MVar--import Network.TLS.Context.Internal-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.IO.Encode-import Network.TLS.Imports-import Network.TLS.Struct-import Network.TLS.Struct13--processHandshake12 :: Context -> Handshake -> IO ()-processHandshake12 ctx hs = do- when (isHRR hs) $ usingHState ctx wrapAsMessageHash13- void $ updateHandshake12 ctx hs- where- isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand- isHRR _ = False--processHandshake13 :: Context -> Handshake13 -> IO ()-processHandshake13 ctx = void . updateHandshake13 ctx---- initialize a new Handshake context (initial handshake or renegotiations)-startHandshake :: Context -> Version -> ClientRandom -> IO ()-startHandshake ctx ver crand =- let hs = Just $ newEmptyHandshake ver crand- in void $ swapMVar (ctxHandshakeState ctx) hs
Network/TLS/Handshake/Random.hs view
@@ -1,13 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module Network.TLS.Handshake.Random ( serverRandom,+ serverRandomECH,+ replaceServerRandomECH, clientRandom, isDowngraded, ) where import qualified Data.ByteString as B+ import Network.TLS.Context.Internal+import Network.TLS.Imports import Network.TLS.Struct -- | Generate a server random suitable for the version selected by the server@@ -34,6 +39,17 @@ pref <- getStateRNG ctx 24 return (pref `B.append` suff) +serverRandomECH :: Context -> IO ServerRandom+serverRandomECH ctx = do+ rnd <- getStateRNG ctx 24+ let zeros = "\x00\x00\x00\x00\x00\x00\x00\x00"+ return $ ServerRandom (rnd <> zeros)++replaceServerRandomECH :: ServerRandom -> ByteString -> ServerRandom+replaceServerRandomECH (ServerRandom rnd) bs = ServerRandom (rnd' <> bs)+ where+ rnd' = B.take 24 rnd+ -- | Test if the negotiated version was artificially downgraded (that is, for -- other reason than the versions supported by the client). isDowngraded :: Version -> [Version] -> ServerRandom -> Bool@@ -47,11 +63,11 @@ suffix11 `B.isSuffixOf` sr | otherwise = False -suffix12 :: B.ByteString-suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01]+suffix12 :: ByteString+suffix12 = "\x44\x4F\x57\x4E\x47\x52\x44\x01" -suffix11 :: B.ByteString-suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00]+suffix11 :: ByteString+suffix11 = "\x44\x4F\x57\x4E\x47\x52\x44\x00" clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32
Network/TLS/Handshake/Server.hs view
@@ -4,15 +4,16 @@ handshakeServer, handshakeServerWith, requestCertificateServer,- postHandshakeAuthServerWith,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where -import Control.Exception (bracket) import Control.Monad.State.Strict+import Data.Maybe import Network.TLS.Context.Internal import Network.TLS.Handshake.Common-import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.ClientHello import Network.TLS.Handshake.Server.ClientHello12 import Network.TLS.Handshake.Server.ClientHello13@@ -20,11 +21,7 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13-import Network.TLS.IO-import Network.TLS.Imports-import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13 -- Put the server context in handshake mode. --@@ -50,43 +47,28 @@ -- When the function returns, a new handshake has been succesfully negociated. -- On any error, a HandshakeFailed exception is raised. handshake :: ServerParams -> Context -> Handshake -> IO ()-handshake sparams ctx clientHello = do- (chosenVersion, ch) <- processClientHello sparams ctx clientHello+handshake sparams ctx (ClientHello ch) = do+ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry.- (mClientKeyShare, r0) <-- processClientHello13 sparams ctx ch+ (mClientKeyShare, r0, r1) <-+ processClientHello13 sparams ctx chI case mClientKeyShare of Nothing -> do- sendHRR ctx r0 ch+ sendHRR ctx r0 chI $ isJust mcrnd -- Don't reset ctxEstablished since 0-RTT data -- would be comming, which should be ignored. handshakeServer sparams ctx Just cliKeyShare -> do- r1 <-- sendServerHello13 sparams ctx cliKeyShare r0 ch- recvClientSecondFlight13 sparams ctx r1 ch+ r2 <-+ sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd+ recvClientSecondFlight13 sparams ctx r2 chI else do r <-- processClientHello12 sparams ctx ch+ processClientHello12 sparams ctx chI resumeSessionData <-- sendServerHello12 sparams ctx r ch+ sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData--newCertReqContext :: Context -> IO CertReqContext-newCertReqContext ctx = getStateRNG ctx 32--requestCertificateServer :: ServerParams -> Context -> IO Bool-requestCertificateServer sparams ctx = do- tls13 <- tls13orLater ctx- supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA- let ok = tls13 && supportsPHA- when ok $ do- certReqCtx <- newCertReqContext ctx- let certReq = makeCertRequest sparams ctx certReqCtx False- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- addCertRequest13 ctx certReq- sendPacket13 ctx $ Handshake13 [certReq]- return ok+handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -1,23 +1,40 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module Network.TLS.Handshake.Server.ClientHello ( processClientHello, ) where +import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as BS++import Network.TLS.ECH.Config+ import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Extension-import Network.TLS.Handshake.Process+import Network.TLS.Handshake.Common+import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types processClientHello- :: ServerParams -> Context -> Handshake -> IO (Version, CH)-processClientHello sparams ctx clientHello@(ClientHello legacyVersion cran compressions ch@CH{..}) = do+ :: ServerParams+ -> Context+ -> ClientHello+ -> IO+ ( Version+ , ClientHello+ , Maybe ClientRandom -- Just for ECH to keep the outer one for key log+ )+processClientHello sparams ctx ch@CH{..} = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do@@ -39,29 +56,26 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - -- Handle Client hello- hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx legacyVersion cran- processHandshake12 ctx clientHello-- when (legacyVersion /= TLS12) $+ when (chVersion /= TLS12) $ throwCore $- Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion+ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when ( supportedFallbackScsv (ctxSupported ctx) && (CipherId 0x5600 `elem` chCiphers)- && legacyVersion < TLS12+ && chVersion < TLS12 ) $ throwCore $ Error_Protocol "fallback is not allowed" InappropriateFallback+ -- choosing TLS version let extract (SupportedVersionsClientHello vers) = vers -- fixme: vers == [] extract _ = []- clientVersions = lookupAndDecode EID_SupportedVersions MsgTClientHello chExtensions [] extract- clientVersion = min TLS12 legacyVersion+ clientVersions =+ lookupAndDecode EID_SupportedVersions MsgTClientHello chExtensions [] extract+ clientVersion = min TLS12 chVersion serverVersions | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx@@ -85,38 +99,78 @@ ProtocolVersion Just v -> return v - -- SNI (Server Name Indication)- let extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns)- toHostName (ServerNameHostName hostName) = Just hostName- toHostName (ServerNameOther _) = Nothing- serverName =- lookupAndDecode- EID_ServerName- MsgTClientHello- chExtensions- Nothing- extractServerName+ -- Checking compression let nullComp = compressionID nullCompression case chosenVersion of TLS13 ->- when (compressions /= [nullComp]) $+ when (chComps /= [nullComp]) $ throwCore $ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter- _ -> case find (== nullComp) compressions of+ _ -> case find (== nullComp) chComps of Nothing -> throwCore $ Error_Protocol "compressions must include nullCompression in TLS 1.2" IllegalParameter _ -> return ()++ -- Processing encrypted client hello+ (mClientHello', receivedECH) <-+ if chosenVersion == TLS13 && (not (null (serverECHKey sparams)))+ then do+ lookupAndDecodeAndDo+ EID_EncryptedClientHello+ MsgTClientHello+ chExtensions+ (return (Nothing, False))+ (\bs -> (,True) <$> decryptECH sparams ctx ch bs)+ else return (Nothing, False)+ case mClientHello' of+ Just chI -> do+ setupI ctx chI+ return (chosenVersion, chI, Just chRandom)+ _ -> do+ setupO ctx ch+ when (chosenVersion == TLS13) $ do+ let hasECHConf = not (null (sharedECHConfigList (serverShared sparams)))+ when (hasECHConf && not receivedECH) $+ usingHState ctx $+ setECHEE True+ when receivedECH $+ usingHState ctx $+ setECHEE True+ return (chosenVersion, ch, Nothing)++setupI :: Context -> ClientHello -> IO ()+setupI ctx chI@CH{..} = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx TLS13 chRandom+ usingHState ctx $ setClientHello chI+ let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName- return (chosenVersion, ch)-processClientHello _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in handshakeServerWith"- HandshakeFailure +setupO :: Context -> ClientHello -> IO ()+setupO ctx ch@CH{..} = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx chVersion chRandom+ usingHState ctx $ setClientHello ch+ let serverName = getServerName chExtensions+ maybe (return ()) (usingState_ ctx . setClientSNI) serverName++-- SNI (Server Name Indication)+getServerName :: [ExtensionRaw] -> Maybe HostName+getServerName chExts =+ lookupAndDecode+ EID_ServerName+ MsgTClientHello+ chExts+ Nothing+ extractServerName+ where+ extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns)+ toHostName (ServerNameHostName hostName) = Just hostName+ toHostName (ServerNameOther _) = Nothing+ findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of@@ -130,3 +184,119 @@ where svs = sortOn Down serverVersions cvs = sortOn Down $ filter (>= TLS12) clientVersions++decryptECH+ :: ServerParams+ -> Context+ -> ClientHello+ -> EncryptedClientHello+ -> IO (Maybe ClientHello)+decryptECH _ _ _ ECHClientHelloInner = return Nothing+decryptECH sparams ctx chO ech@ECHClientHelloOuter{..} = E.handle hpkeHandler $ do+ mfunc <- getHPKE sparams ctx ech+ case mfunc of+ Nothing -> return Nothing+ Just (func, nenc) -> do+ hrr <- usingState_ ctx getTLS13HRR+ let nenc' = if hrr then 0 else nenc+ let aad = encodeHandshake' $ ClientHello $ fill0ClientHello nenc' chO+ plaintext <- func aad echPayload+ case decodeClientHello' plaintext of+ Right (ClientHello chI) -> do+ case expandClientHello chI chO of+ Nothing -> return Nothing+ Just chI' -> return $ Just chI'+ _ -> return Nothing+ where+ hpkeHandler :: HPKEError -> IO (Maybe ClientHello)+ hpkeHandler _ = return Nothing+decryptECH _ _ _ _ = return Nothing++fill0ClientHello :: Int -> ClientHello -> ClientHello+fill0ClientHello nenc ch@CH{..} =+ ch{chExtensions = fill0Exts nenc chExtensions}++fill0Exts :: Int -> [ExtensionRaw] -> [ExtensionRaw]+fill0Exts nenc xs0 = loop xs0+ where+ loop [] = []+ loop (ExtensionRaw EID_EncryptedClientHello bs : xs) = x' : loop xs+ where+ (prefix, payload) = BS.splitAt (10 + nenc) bs+ bs' = prefix <> BS.replicate (BS.length payload) 0+ x' = ExtensionRaw EID_EncryptedClientHello bs'+ loop (x : xs) = x : loop xs++expandClientHello :: ClientHello -> ClientHello -> Maybe ClientHello+expandClientHello inner outer =+ case expand (chExtensions inner) (chExtensions outer) of+ Nothing -> Nothing+ Just exts ->+ Just $+ inner+ { chSession = chSession outer+ , chExtensions = exts+ }+ where+ expand :: [ExtensionRaw] -> [ExtensionRaw] -> Maybe [ExtensionRaw]+ expand [] _ = Just []+ expand iis [] = chk iis+ expand (i : is) oos = do+ (rs, oos') <- case i of+ ExtensionRaw EID_EchOuterExtensions bs ->+ case extensionDecode MsgTClientHello bs of+ Nothing -> Nothing+ Just (EchOuterExtensions eids) -> expd eids oos+ _ -> Just ([i], oos)+ (rs ++) <$> expand is oos'+ expd+ :: [ExtensionID] -> [ExtensionRaw] -> Maybe ([ExtensionRaw], [ExtensionRaw])+ expd [] oos = Just ([], oos)+ expd _ [] = Nothing+ expd (i : is) oos = case fnd i oos of+ Nothing -> Nothing+ Just (ext, oos') -> do+ (exts, oos'') <- expd is oos'+ Just (ext : exts, oos'')+ fnd :: ExtensionID -> [ExtensionRaw] -> Maybe (ExtensionRaw, [ExtensionRaw])+ fnd _ [] = Nothing+ fnd EID_EncryptedClientHello _ = Nothing+ fnd i (o@(ExtensionRaw eid _) : os)+ | i == eid = Just (o, os)+ | otherwise = fnd i os+ chk :: [ExtensionRaw] -> Maybe [ExtensionRaw]+ chk [] = Just []+ chk (ExtensionRaw EID_EchOuterExtensions _ : _) = Nothing+ chk (i : is) = (i :) <$> chk is++getHPKE+ :: ServerParams+ -> Context+ -> EncryptedClientHello+ -> IO (Maybe (HPKEF, Int))+getHPKE ServerParams{..} ctx ECHClientHelloOuter{..} = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let mconfig = findECHConfigById echConfigId $ sharedECHConfigList serverShared+ mskR = lookup echConfigId serverECHKey+ case (mconfig, mskR) of+ (Just config, Just skR') -> do+ let kemid = KEM_ID $ kem_id $ key_config $ contents config+ skR = EncodedSecretKey skR'+ encodedConfig = encodeECHConfig config+ let info = "tls ech\x00" <> encodedConfig+ (kdfid, aeadid) = echCipherSuite+ ctxR <- setupBaseR kemid kdfid aeadid skR Nothing echEnc info+ let nenc = nEnc kemid+ func = open ctxR+ setTLS13HPKE ctx func nenc+ return $ Just (func, nenc)+ _ -> return Nothing+ _ -> return mfunc+getHPKE _ _ _ = return Nothing++findECHConfigById :: ConfigId -> ECHConfigList -> Maybe ECHConfig+findECHConfigById cnfId echConfigList = find eqCfgId echConfigList+ where+ eqCfgId cnf = config_id (key_config (contents cnf)) == cnfId
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -13,6 +13,7 @@ import Network.TLS.Extension import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.State@@ -27,7 +28,7 @@ processClientHello12 :: ServerParams -> Context- -> CH+ -> ClientHello -> IO (Cipher, Maybe Credential) processClientHello12 sparams ctx ch = do let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams@@ -45,9 +46,10 @@ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds+ void $ updateTranscriptHash12 ctx $ ClientHello ch return (usedCipher, mcred) -checkSecureRenegotiation :: Context -> CH -> IO ()+checkSecureRenegotiation :: Context -> ClientHello -> IO () checkSecureRenegotiation ctx CH{..} = do -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}@@ -71,7 +73,7 @@ credsTriple :: ServerParams- -> CH+ -> ClientHello -> Credentials -> (Credentials, Credentials, [Cipher]) credsTriple sparams CH{..} extraCreds
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -3,31 +3,37 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13,- sendHRR, ) where +import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports+import Network.TLS.Packet import Network.TLS.Parameters+import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13 import Network.TLS.Types -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context- -> CH- -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool))-processClientHello13 sparams ctx CH{..} = do+ -> ClientHello+ -> IO+ ( Maybe KeyShareEntry+ , (Cipher, Hash, Bool)+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+ )+processClientHello13 sparams ctx ch@CH{..} = do when (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) $ throwCore@@ -68,7 +74,11 @@ keyShares <- lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract mshare <- findKeyShare keyShares serverGroups- return (mshare, (usedCipher, usedHash, rtt0))+ let triple = (usedCipher, usedHash, rtt0)+ pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch+ clientHello <- fromJust <$> usingHState ctx getClientHello+ void $ updateTranscriptHash12 ctx $ ClientHello clientHello+ return (mshare, triple, pskEarlySecret) where ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers =@@ -91,34 +101,93 @@ _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter grpEq g ent = g == keyShareEntryGroup ent -sendHRR :: Context -> (Cipher, a, b) -> CH -> IO ()-sendHRR ctx (usedCipher, _, _) CH{..} = do- twice <- usingState_ ctx getTLS13HRR- when twice $- throwCore $- Error_Protocol "Hello retry not allowed again" HandshakeFailure- usingState_ ctx $ setTLS13HRR True- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- let clientGroups =- lookupAndDecode- EID_SupportedGroups- MsgTClientHello- chExtensions- []- (\(SupportedGroups gs) -> gs)- possibleGroups = serverGroups `intersect` clientGroups- case possibleGroups of- [] ->- throwCore $- Error_Protocol "no group in common with the client for HRR" HandshakeFailure- g : _ -> do- let keyShareExt = toExtensionRaw $ KeyShareHRR g- versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13- extensions = [keyShareExt, versionExt]- hrr = ServerHello13 hrrRandom chSession (CipherId $ cipherID usedCipher) extensions- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [hrr]- sendChangeCipherSpec13 ctx+pskAndEarlySecret+ :: ServerParams+ -> Context+ -> (Cipher, Hash, Bool)+ -> ClientHello+ -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do+ (psk, binderInfo, is0RTTvalid) <- choosePSK+ earlyKey <- calculateEarlySecret ctx choice (Left psk)+ let earlySecret = pairBase earlyKey+ authenticated = isJust binderInfo+ preSharedKeyExt <- checkBinder earlySecret binderInfo+ return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) where- serverGroups = supportedGroups (ctxSupported ctx)+ choice = makeCipherChoice TLS13 usedCipher++ choosePSK =+ lookupAndDecodeAndDo+ EID_PreSharedKey+ MsgTClientHello+ chExtensions+ (return (zero, Nothing, False))+ selectPSK++ selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do+ when (null dhModes) $+ throwCore $+ Error_Protocol "no psk_key_exchange_modes extension" MissingExtension+ if PSK_DHE_KE `elem` dhModes+ 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 identity+ else sessionResume mgr identity+ case msdata of+ Just sdata -> do+ let tinfo = fromJust $ sessionTicketInfo sdata+ psk = sessionSecret sdata+ isFresh <- checkFreshness tinfo obfAge+ (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata+ if isPSKvalid && isFresh+ then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)+ else -- fall back to full handshake+ return (zero, Nothing, False)+ _ -> return (zero, Nothing, False)+ else return (zero, Nothing, False)+ selectPSK _ = return (zero, Nothing, False)++ checkBinder _ Nothing = return []+ checkBinder earlySecret (Just (binder, n, tlen)) = do+ ch <- fromJust <$> usingHState ctx getClientHello+ let ech = encodeHandshake $ ClientHello ch+ binder' = makePSKBinder earlySecret usedHash tlen ech+ unless (binder == binder') $+ decryptError "PSK binder validation failed"+ return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]++ checkSessionEquality sdata = do+ msni <- usingState_ ctx getClientSNI+ -- ALPN should be checked.+ -- But it's an extension in EE, sigh.+ -- malpn <- usingState_ ctx getNegotiatedProtocol+ let isSameSNI = sessionClientSNI sdata == msni+ isSameCipher = sessionCipher sdata == cipherID usedCipher+ ciphers = supportedCiphers $ serverSupported sparams+ scid = sessionCipher sdata+ isSameKDF = case findCipher scid ciphers of+ Nothing -> False+ Just c -> cipherHash c == cipherHash usedCipher+ isSameVersion = TLS13 == sessionVersion sdata+ -- isSameALPN = sessionALPN sdata == malpn+ isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required+ is0RTTvalid = isSameVersion && isSameCipher -- && isSameALPN+ return (isPSKvalid, is0RTTvalid)++ dhModes =+ lookupAndDecode+ EID_PskKeyExchangeModes+ MsgTClientHello+ chExtensions+ []+ (\(PskKeyExchangeModes ms) -> ms)++ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -31,7 +31,7 @@ :: ServerParams -> Context -> (Cipher, Maybe Credential)- -> CH+ -> ClientHello -> IO (Maybe SessionData) sendServerHello12 sparams ctx (usedCipher, mcred) ch@CH{..} = do resumeSessionData <- recoverSessionData ctx ch@@ -39,26 +39,25 @@ Nothing -> do serverSession <- newSession ctx usingState_ ctx $ setSession serverSession- serverhello <-- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions- let ff = serverhello : build [ServerHelloDone]+ let ff = ServerHello sh : build [ServerHelloDone] sendPacket12 ctx $ Handshake ff contextFlush ctx Just sessionData -> do usingState_ ctx $ do setSession chSession setTLS12SessionResuming True- serverhello <-+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession- sendPacket12 ctx $ Handshake [serverhello]+ sendPacket12 ctx $ Handshake [ServerHello sh] let mainSecret = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole return resumeSessionData -recoverSessionData :: Context -> CH -> IO (Maybe SessionData)+recoverSessionData :: Context -> ClientHello -> IO (Maybe SessionData) recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions@@ -116,7 +115,7 @@ let cc = case mcred of Just (srvCerts, _) -> srvCerts _ -> CertificateChain []- let b1 = b0 . (Certificate (TLSCertificateChain cc) :)+ let b1 = b0 . (Certificate (CertificateChain_ cc) :) usingState_ ctx $ setServerCertificateChain cc -- send server key exchange if needed@@ -236,11 +235,9 @@ -> Maybe Credential -> [ExtensionRaw] -> Session- -> IO Handshake+ -> IO ServerHello makeServerHello sparams ctx usedCipher mcred chExts session = do resuming <- usingState_ ctx getTLS12SessionResuming- srand <-- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams case mcred of Just cred -> storePrivInfoServer ctx cred _ -> return () -- return a sensible error@@ -288,6 +285,9 @@ recodeSizeLimitExt <- processRecordSizeLimit ctx chExts False + srand <-+ serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams+ let shExts = sharedHelloExtensions (serverShared sparams) ++ catMaybes@@ -300,16 +300,16 @@ , {- 0xff01 -} secureRenegExt ] usingState_ ctx $ setVersion TLS12- usingHState ctx $- setServerHelloParameters TLS12 srand usedCipher nullCompression+ setServerHelloParameters12 ctx TLS12 srand usedCipher nullCompression return $- ServerHello- TLS12- srand- session- (CipherId (cipherID usedCipher))- (compressionID nullCompression)- shExts+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = session+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ } negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon serverGroups chExts =
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -3,10 +3,10 @@ module Network.TLS.Handshake.Server.ServerHello13 ( sendServerHello13,+ sendHRR, ) where import Control.Monad.State.Strict-import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -22,10 +22,10 @@ import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters-import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -37,14 +37,18 @@ -> Context -> KeyShareEntry -> (Cipher, Hash, Bool)- -> CH+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+ -> ClientHello+ -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret , Bool , Bool )-sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do+sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do+ let clientEarlySecret = pairClient earlyKey+ earlySecret = pairBase earlyKey -- parse CompressCertificate to check if it is broken here let zlib = lookupAndDecode@@ -60,18 +64,13 @@ newSession ctx >>= \ss -> usingState_ ctx $ do setSession ss setTLS13ClientSupportsPHA supportsPHA- usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare- srand <- setServerParameter- -- ALPN is used in choosePSK- alpnExt <- applicationProtocol ctx chExtensions sparams- (psk, binderInfo, is0RTTvalid) <- choosePSK- earlyKey <- calculateEarlySecret ctx choice (Left psk) True- let earlySecret = pairBase earlyKey- clientEarlySecret = pairClient earlyKey- extensions <- checkBinder earlySecret binderInfo+ usingHState ctx $ do+ setSupportedGroup $ keyShareEntryGroup clientKeyShare+ setOuterClientRandom mOuterClientRandom hrr <- usingState_ ctx getTLS13HRR- let authenticated = isJust binderInfo- rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ alpnExt <- applicationProtocol ctx chExtensions sparams+ setServerParameter+ let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) let p = makeCredentialPredicate TLS13 chExtensions@@ -96,7 +95,7 @@ (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do- sendServerHello keyShare srand extensions+ sendServerHello keyShare sendChangeCipherSpec13 ctx ---------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe@@ -124,7 +123,7 @@ loadPacket13 ctx $ Handshake13 [rawFinished] return (clientHandshakeSecret, handSecret) ----------------------------------------------------------------- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" appKey <- calculateApplicationSecret ctx choice handSecret hChSf let clientApplicationSecret0 = triClient appKey serverApplicationSecret0 = triServer appKey@@ -138,11 +137,8 @@ choice = makeCipherChoice TLS13 usedCipher setServerParameter = do- srand <-- serverRandom ctx TLS13 $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion TLS13- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- return srand+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher False supportsPHA = lookupAndDecode@@ -152,69 +148,9 @@ False (\PostHandshakeAuth -> True) - selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do- when (null dhModes) $- throwCore $- Error_Protocol "no psk_key_exchange_modes extension" MissingExtension- if PSK_DHE_KE `elem` dhModes- 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 identity- else sessionResume mgr identity- case msdata of- Just sdata -> do- let tinfo = fromJust $ sessionTicketInfo sdata- psk = sessionSecret sdata- isFresh <- checkFreshness tinfo obfAge- (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata- if isPSKvalid && isFresh- then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)- else -- fall back to full handshake- return (zero, Nothing, False)- _ -> return (zero, Nothing, False)- else return (zero, Nothing, False)- selectPSK _ = return (zero, Nothing, False)-- choosePSK =- lookupAndDecodeAndDo- EID_PreSharedKey- MsgTClientHello- chExtensions- (return (zero, Nothing, False))- selectPSK-- checkSessionEquality sdata = do- msni <- usingState_ ctx getClientSNI- malpn <- usingState_ ctx getNegotiatedProtocol- let isSameSNI = sessionClientSNI sdata == msni- isSameCipher = sessionCipher sdata == cipherID usedCipher- ciphers = supportedCiphers $ serverSupported sparams- scid = sessionCipher sdata- isSameKDF = case findCipher scid ciphers of- Nothing -> False- Just c -> cipherHash c == cipherHash usedCipher- isSameVersion = TLS13 == sessionVersion sdata- isSameALPN = sessionALPN sdata == malpn- isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required- is0RTTvalid = isSameVersion && isSameCipher && isSameALPN- return (isPSKvalid, is0RTTvalid)- rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams rtt0accept = serverEarlyDataSize sparams > 0 - checkBinder _ Nothing = return []- checkBinder earlySecret (Just (binder, n, tlen)) = do- binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing- unless (binder == binder') $- decryptError "PSK binder validation failed"- return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]- decideCredentialInfo allCreds = do let err = throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError@@ -239,12 +175,52 @@ mcs -> return mcs mcs -> return mcs - sendServerHello keyShare srand extensions = do+ sendServerHello keyShare = do let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13- extensions' = keyShareExt : versionExt : extensions- helo = ServerHello13 srand chSession (CipherId (cipherID usedCipher)) extensions'- loadPacket13 ctx $ Handshake13 [helo]+ shExts = keyShareExt : versionExt : preSharedKeyExt+ if isJust $ mOuterClientRandom+ then do+ srand <- liftIO $ serverRandomECH ctx+ let cipherId = CipherId (cipherID usedCipher)+ sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ suffix <- computeConfirm ctx usedHash sh "ech accept confirmation"+ let srand' = replaceServerRandomECH srand suffix+ sh' =+ SH+ { shVersion = TLS12+ , shRandom = srand'+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ usingHState ctx $ setECHAccepted True+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh']+ else do+ srand <-+ liftIO $+ serverRandom ctx TLS13 $+ supportedVersions $+ serverSupported sparams+ let sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ }+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh] sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred@@ -258,9 +234,9 @@ ess = replicate (length cs) [] let certtag = if zlib then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [certtag "" (TLSCertificateChain certChain) ess]+ Handshake13 [certtag "" (CertificateChain_ certChain) ess] liftIO $ usingState_ ctx $ setServerCertificateChain certChain- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc loadPacket13 ctx $ Handshake13 [vrfy]@@ -288,7 +264,16 @@ | rtt0OK = Just $ toExtensionRaw $ EarlyDataIndication Nothing | otherwise = Nothing - let extensions =+ sendECH <- usingHState ctx getECHEE+ let echExt+ | sendECH =+ Just $+ toExtensionRaw $+ ECHEncryptedExtensions $+ sharedECHConfigList $+ serverShared sparams+ | otherwise = Nothing+ let eeExtensions = sharedHelloExtensions (serverShared sparams) ++ catMaybes [ {- 0x00 -} sniExt@@ -296,21 +281,11 @@ , {- 0x10 -} alpnExt , {- 0x1c -} recodeSizeLimitExt , {- 0x2a -} earlyDataExt+ , {- 0xfe0d -} echExt ]- extensions' <-- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions- loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions']-- dhModes =- lookupAndDecode- EID_PskKeyExchangeModes- MsgTClientHello- chExtensions- []- (\(PskKeyExchangeModes ms) -> ms)-- hashSize = hashDigestSize usedHash- zero = B.replicate hashSize 0+ eeExtensions' <-+ liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]@@ -335,3 +310,73 @@ contextSync :: Context -> ServerState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync _ sync -> sync ctx ctl++----------------------------------------------------------------++sendHRR :: Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()+sendHRR ctx (usedCipher, usedHash, _) CH{..} isEch = do+ twice <- usingState_ ctx getTLS13HRR+ when twice $+ throwCore $+ Error_Protocol "Hello retry not allowed again" HandshakeFailure+ usingState_ ctx $ setTLS13HRR True+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher True+ let clientGroups =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExtensions+ []+ (\(SupportedGroups gs) -> gs)+ possibleGroups = serverGroups `intersect` clientGroups+ case possibleGroups of+ [] ->+ throwCore $+ Error_Protocol "no group in common with the client for HRR" HandshakeFailure+ g : _ -> do+ hrr <- makeHRR ctx usedCipher usedHash chSession g isEch+ usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+ runPacketFlight ctx $ do+ loadPacket13 ctx $ Handshake13 [ServerHello13 hrr]+ sendChangeCipherSpec13 ctx+ where+ serverGroups = supportedGroups (ctxSupported ctx)++makeHRR+ :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello+makeHRR _ usedCipher _ session g False = return hrr+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ extensions = [keyShareExt, versionExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }+makeHRR ctx usedCipher usedHash session g True = do+ suffix <- computeConfirm ctx usedHash hrr "hrr ech accept confirmation"+ let echExt' = toExtensionRaw $ ECHHelloRetryRequest suffix+ extensions' = [keyShareExt, versionExt, echExt']+ hrr' = hrr{shExtensions = extensions'}+ return hrr'+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ echExt = toExtensionRaw $ ECHHelloRetryRequest "\x00\x00\x00\x00\x00\x00\x00\x00"+ extensions = [keyShareExt, versionExt, echExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }
Network/TLS/Handshake/Server/TLS12.hs view
@@ -45,7 +45,7 @@ Just _ -> do _ <- sessionEstablished ctx recvCCSandFinished ctx- handshakeDone12 ctx+ finishHandshake12 ctx where adjustLifetime i | i < 0 = 0@@ -83,7 +83,7 @@ recvClientCCC :: ServerParams -> Context -> IO () recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate) where- expectClientCertificate (Certificate (TLSCertificateChain certs)) = do+ expectClientCertificate (Certificate (CertificateChain_ certs)) = do clientCertificate sparams ctx certs processCertificate ctx ServerRole certs
Network/TLS/Handshake/Server/TLS13.hs view
@@ -3,32 +3,43 @@ module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13,- postHandshakeAuthServerWith,+ requestCertificateServer,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where +import Control.Exception import Control.Monad.State.Strict+import qualified Data.ByteString.Char8 as C8+import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal+import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common hiding (expectFinished) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports+import Network.TLS.KeySchedule import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types+import Network.TLS.Util import Network.TLS.X509 +----------------------------------------------------------------+ recvClientSecondFlight13 :: ServerParams -> Context@@ -37,7 +48,7 @@ , Bool , Bool )- -> CH+ -> ClientHello -> IO () recvClientSecondFlight13 sparams ctx (appKey, clientHandshakeSecret, authenticated, rtt0OK) CH{..} = do sfSentTime <- getCurrentTimeFromBase@@ -46,20 +57,20 @@ if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do recvHandshake13 ctx $ expectCertificate sparams ctx- recvHandshake13hash ctx (expectCertVerify sparams ctx)- recvHandshake13hash ctx expectFinished'+ recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx)+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx else if rtt0OK && not (ctxQUICMode ctx) then setPendingRecvActions ctx- [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret+ [ PendingRecvAction True True $ expectEndOfEarlyData ctx clientHandshakeSecret , PendingRecvActionHash True $ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ] else runRecvHandshake13 $ do- recvHandshake13hash ctx expectFinished'+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx expectFinished@@ -70,7 +81,7 @@ -> SecretTriple ApplicationSecret -> ClientTrafficSecret HandshakeSecret -> Word64- -> ByteString+ -> TranscriptHash -> Handshake13 -> m () expectFinished sparams ctx exts appKey clientHandshakeSecret sfSentTime hChBeforeCf (Finished13 verifyData) = liftIO $ do@@ -78,7 +89,7 @@ (usedHash, usedCipher, _, _) <- getRxRecordState ctx let ClientTrafficSecret chs = clientHandshakeSecret checkFinished ctx usedHash chs hChBeforeCf verifyData- handshakeDone13 ctx+ finishHandshake13 ctx setRxRecordState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime where@@ -95,13 +106,13 @@ expectCertificate :: MonadIO m => ServerParams -> Context -> Handshake13 -> m ()-expectCertificate sparams ctx (Certificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do+expectCertificate sparams ctx (Certificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs-expectCertificate sparams ctx (CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do+expectCertificate sparams ctx (CompressedCertificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter@@ -120,7 +131,7 @@ sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime = when sendNST $ do cfRecvTime <- getCurrentTimeFromBase let rtt = cfRecvTime - sfSentTime- nonce <- getStateRNG ctx 32+ nonce <- TicketNonce <$> getStateRNG ctx 32 resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret let life = adjustLifetime $ serverTicketLifetime sparams psk = derivePSK choice resumptionSecret nonce@@ -143,22 +154,22 @@ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk let mgr = sharedSessionManager $ serverShared sparams mticket <- sessionEstablish mgr sessionId sdata- let identity = fromMaybe sessionId mticket+ let identity = SessionIDorTicket_ $ fromMaybe sessionId mticket return (identity, ageAdd tinfo) createNewSessionTicket life add nonce identity maxSize =- NewSessionTicket13 life add nonce identity extensions+ NewSessionTicket13 life add nonce identity nstExtensions where earlyDataExt = toExtensionRaw $ EarlyDataIndication $ Just $ fromIntegral maxSize- extensions = [earlyDataExt]+ nstExtensions = [earlyDataExt] adjustLifetime i | i < 0 = 0 | i > 604800 = 604800 | otherwise = fromIntegral i expectCertVerify- :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()-expectCertVerify sparams ctx hChCc (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do+ :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of@@ -196,56 +207,167 @@ usingState_ ctx $ setClientCertificateChain certs else decryptError "verification failed" -postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h-postHandshakeAuthServerWith sparams ctx h@(CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h-postHandshakeAuthServerWith _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in postHandshakeAuthServerWith"- UnexpectedMessage+---------------------------------------------------------------- -processHandshakeAuthServerWith+newCertReqContext :: Context -> IO CertReqContext+newCertReqContext ctx = getStateRNG ctx 32++requestCertificateServer :: ServerParams -> Context -> IO Bool+requestCertificateServer sparams ctx = handleEx ctx $ do+ tls13 <- tls13orLater ctx+ supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA+ let ok = tls13 && supportsPHA+ if ok+ then newIORef [] >>= sendCertReqAndRecv+ else return ok+ where+ sendCertReqAndRecv ref = do+ origCertReqCtx <- newCertReqContext ctx+ let certReq13 = makeCertRequest sparams ctx origCertReqCtx False+ _ <- withWriteLock ctx $ do+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ sendPacket13 ctx $ Handshake13 [certReq13]+ withReadLock ctx $ do+ clientCert13 <- getHandshake ctx ref+ emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13+ baseHState <- saveHState ctx+ void $ updateTranscriptHash13 ctx certReq13+ void $ updateTranscriptHash13 ctx clientCert13+ th <- transcriptHash ctx "CH..Cert"+ unless emptyCert $ do+ certVerify13 <- getHandshake ctx ref+ expectCertVerify sparams ctx th certVerify13+ void $ updateTranscriptHash13 ctx certVerify13+ finished13 <- getHandshake ctx ref+ expectClientFinished ctx finished13+ void $ restoreHState ctx baseHState -- fixme+ return True++-- saving appdata and key update?+-- error handling+getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13+getHandshake ctx ref = do+ hhs <- readIORef ref+ if null hhs+ then do+ ex <- recvPacket13 ctx+ either (terminate ctx) process ex+ else chk hhs+ where+ process (Handshake13 iss) = chk iss+ process _ =+ terminate ctx $+ Error_Protocol "post handshake authenticated" UnexpectedMessage+ chk [] = getHandshake ctx ref+ chk (KeyUpdate13 mode : hs) = do+ keyUpdate ctx getRxRecordState setRxRecordState+ -- Write lock wraps both actions because we don't want another+ -- packet to be sent by another thread before the Tx state is+ -- updated.+ when (mode == UpdateRequested) $ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+ keyUpdate ctx getTxRecordState setTxRecordState+ chk hs+ chk (h : hs) = do+ writeIORef ref hs+ return h++expectClientCertificate+ :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool+expectClientCertificate sparams ctx origCertReqCtx (Certificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate sparams ctx origCertReqCtx (CompressedCertificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate _ _ _ h = unexpected "Certificate" $ Just $ show h++expectClientCertificate' :: ServerParams -> Context -> CertReqContext+ -> CertReqContext -> CertificateChain- -> Handshake13 -> IO ()-processHandshakeAuthServerWith sparams ctx certCtx certs h = do- mCertReq <- getCertRequest13 ctx certCtx- when (isNothing mCertReq) $+expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs = do+ when (origCertReqCtx /= certReqCtx) $ throwCore $- Error_Protocol "unknown certificate request context" DecodeError- let certReq = fromJust mCertReq-- -- fixme checking _ext- clientCertificate sparams ctx certs-- baseHState <- saveHState ctx- processHandshake13 ctx certReq- processHandshake13 ctx h+ Error_Protocol "certificate context is wrong" IllegalParameter+ void $ clientCertificate sparams ctx certs +expectClientFinished :: Context -> Handshake13 -> IO ()+expectClientFinished ctx (Finished13 verifyData) = do (usedHash, _, level, applicationSecretN) <- getRxRecordState ctx unless (level == CryptApplicationSecret) $ throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError+ hChBeforeCf <- transcriptHash ctx "CH..<CF"+ checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData+expectClientFinished _ h = unexpected "Finished" $ Just $ show h - let expectFinished' hChBeforeCf (Finished13 verifyData) = do- checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData- void $ restoreHState ctx baseHState- expectFinished' _ hs = unexpected (show hs) (Just "finished 13")+terminate :: Context -> TLSError -> IO a+terminate ctx err = do+ let (level, desc) = errorToAlert err+ reason = errorToAlertMessage err+ send = sendPacket13 ctx . Alert13+ catchException (send [(level, desc)]) (\_ -> return ())+ setEOF ctx+ throwIO $ Terminated False reason err - -- 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 setPendingRecvActions ctx [PendingRecvActionHash False expectFinished']- else- setPendingRecvActions- ctx- [ PendingRecvActionHash False (expectCertVerify sparams ctx)- , PendingRecvActionHash False expectFinished'- ]+handleEx :: Context -> IO Bool -> IO Bool+handleEx ctx f = catchException f $ \exception -> do+ -- If the error was an Uncontextualized TLSException, we replace the+ -- context with HandshakeFailed. If it's anything else, we convert+ -- it to a string and wrap it with Error_Misc and HandshakeFailed.+ let tlserror = case fromException exception of+ Just e | Uncontextualized e' <- e -> e'+ _ -> Error_Misc (show exception)+ sendPacket13 ctx $ Alert13 [errorToAlert tlserror]+ void $ throwIO $ PostHandshake tlserror+ return False++----------------------------------------------------------------++keyUpdate+ :: Context+ -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))+ -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())+ -> IO ()+keyUpdate ctx getState setState = do+ (usedHash, usedCipher, level, applicationSecretN) <- getState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $+ Error_Protocol+ "tried key update without application traffic secret"+ InternalError+ let applicationSecretN1 =+ hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $+ hashDigestSize usedHash+ setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)++-- | How to update keys in TLS 1.3+data KeyUpdateRequest+ = -- | Unidirectional key update+ OneWay+ | -- | Bidirectional key update (normal case)+ TwoWay+ deriving (Eq, Show)++-- | Updating appication traffic secrets for TLS 1.3.+-- If this API is called for TLS 1.3, 'True' is returned.+-- Otherwise, 'False' is returned.+updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool+updateKey ctx way = liftIO $ do+ tls13 <- tls13orLater ctx+ when tls13 $ do+ let req = case way of+ OneWay -> UpdateNotRequested+ TwoWay -> UpdateRequested+ -- Write lock wraps both actions because we don't want another packet to+ -- be sent by another thread before the Tx state is updated.+ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]+ keyUpdate ctx getTxRecordState setTxRecordState+ return tls13
Network/TLS/Handshake/State.hs view
@@ -4,7 +4,7 @@ module Network.TLS.Handshake.State ( HandshakeState (..),- HandshakeDigest (..),+ TransHashState (..), HandshakeMode13 (..), RTT0Status (..), CertReqCBdata,@@ -27,6 +27,16 @@ getGroupPrivate, -- * cert accessors+ setClientRandom,+ getClientRandom,+ setOuterClientRandom,+ getOuterClientRandom,+ setClientHello,+ getClientHello,+ setECHEE,+ getECHEE,+ setECHAccepted,+ getECHAccepted, setClientCertSent, getClientCertSent, setCertReqSent,@@ -42,11 +52,7 @@ -- * digest accessors addHandshakeMessage,- updateHandshakeDigest, getHandshakeMessages,- getHandshakeMessagesRev,- getHandshakeDigest,- foldHandshakeDigest, -- * main secret setMainSecret,@@ -54,7 +60,6 @@ -- * misc accessor getPendingCipher,- setServerHelloParameters, setExtendedMainSecret, getExtendedMainSecret, setSupportedGroup,@@ -95,14 +100,25 @@ } deriving (Show) -data HandshakeDigest- = HandshakeMessages [ByteString]- | HandshakeDigestContext HashCtx- deriving (Show)+data TransHashState+ = -- | Initial state+ TransHashState0+ | -- | A raw CH is stored since hash algo is not chosen yet.+ TransHashState1 ByteString+ | -- | Hashed+ TransHashState2 HashCtx +{- FOURMOLU_DISABLE -}+instance Show TransHashState where+ show TransHashState0 = "State0 "+ show (TransHashState1 _) = "State1 CH"+ show (TransHashState2 hctx) = showBytesHex $ hashFinal hctx+{- FOURMOLU_ENABLE -}+ data HandshakeState = HandshakeState { hstClientVersion :: Version , hstClientRandom :: ClientRandom+ -- ^ For ECH, inner client random. , hstServerRandom :: Maybe ServerRandom , hstMainSecret :: Maybe ByteString , hstKeyState :: HandshakeKeyState@@ -110,8 +126,11 @@ , hstDHPrivate :: Maybe DHPrivate , hstServerECDHParams :: Maybe ServerECDHParams , hstGroupPrivate :: Maybe GroupPrivate- , hstHandshakeDigest :: HandshakeDigest+ , hstTransHashState :: TransHashState+ , hstTransHashStateI :: TransHashState -- Inner CH for client ECH , hstHandshakeMessages :: [ByteString]+ -- ^ To create certificate verify for TLS 1.2.+ -- This should be removed when TLS 1.2 is dropped. , hstCertReqToken :: Maybe ByteString -- ^ Set to Just-value when a TLS13 certificate request is received , hstCertReqCBdata :: Maybe CertReqCBdata@@ -140,6 +159,12 @@ , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool , hstCCS13Recv :: Bool+ , hstTLS13OuterClientRandom :: Maybe ClientRandom+ -- ^ Used for key logging in the case of ECH.+ , hstTLS13ClientHello :: Maybe ClientHello+ -- ^ Inner client hello in the case of ECH.+ , hstTLS13ECHAccepted :: Bool+ , hstTLS13ECHEE :: Bool } deriving (Show) @@ -212,7 +237,8 @@ , hstDHPrivate = Nothing , hstServerECDHParams = Nothing , hstGroupPrivate = Nothing- , hstHandshakeDigest = HandshakeMessages []+ , hstTransHashState = TransHashState0+ , hstTransHashStateI = TransHashState0 , hstHandshakeMessages = [] , hstCertReqToken = Nothing , hstCertReqCBdata = Nothing@@ -233,18 +259,22 @@ , hstTLS13CertComp = False , hstCCS13Sent = False , hstCCS13Recv = False+ , hstTLS13OuterClientRandom = Nothing+ , hstTLS13ClientHello = Nothing+ , hstTLS13ECHAccepted = False+ , hstTLS13ECHEE = False } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) runHandshake hst f = runState (runHandshakeM f) hst setPublicKey :: PubKey -> HandshakeM ()-setPublicKey pk = modify (\hst -> hst{hstKeyState = setPK (hstKeyState hst)})+setPublicKey pk = modify' (\hst -> hst{hstKeyState = setPK (hstKeyState hst)}) where setPK hks = hks{hksRemotePublicKey = Just pk} setPublicPrivateKeys :: (PubKey, PrivKey) -> HandshakeM ()-setPublicPrivateKeys keys = modify (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)})+setPublicPrivateKeys keys = modify' (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)}) where setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} @@ -256,19 +286,19 @@ fromJust <$> gets (hksLocalPublicPrivateKeys . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM ()-setServerDHParams shp = modify (\hst -> hst{hstServerDHParams = Just shp})+setServerDHParams shp = modify' (\hst -> hst{hstServerDHParams = Just shp}) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust <$> gets hstServerDHParams setServerECDHParams :: ServerECDHParams -> HandshakeM ()-setServerECDHParams shp = modify (\hst -> hst{hstServerECDHParams = Just shp})+setServerECDHParams shp = modify' (\hst -> hst{hstServerECDHParams = Just shp}) getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust <$> gets hstServerECDHParams setDHPrivate :: DHPrivate -> HandshakeM ()-setDHPrivate shp = modify (\hst -> hst{hstDHPrivate = Just shp})+setDHPrivate shp = modify' (\hst -> hst{hstDHPrivate = Just shp}) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate@@ -277,16 +307,16 @@ getGroupPrivate = fromJust <$> gets hstGroupPrivate setGroupPrivate :: GroupPrivate -> HandshakeM ()-setGroupPrivate shp = modify (\hst -> hst{hstGroupPrivate = Just shp})+setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = Just shp}) setExtendedMainSecret :: Bool -> HandshakeM ()-setExtendedMainSecret b = modify (\hst -> hst{hstExtendedMainSecret = b})+setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b}) getExtendedMainSecret :: HandshakeM Bool getExtendedMainSecret = gets hstExtendedMainSecret setSupportedGroup :: Group -> HandshakeM ()-setSupportedGroup g = modify (\hst -> hst{hstSupportedGroup = Just g})+setSupportedGroup g = modify' (\hst -> hst{hstSupportedGroup = Just g}) getSupportedGroup :: HandshakeM (Maybe Group) getSupportedGroup = gets hstSupportedGroup@@ -304,7 +334,7 @@ deriving (Show, Eq) setTLS13HandshakeMode :: HandshakeMode13 -> HandshakeM ()-setTLS13HandshakeMode s = modify (\hst -> hst{hstTLS13HandshakeMode = s})+setTLS13HandshakeMode s = modify' (\hst -> hst{hstTLS13HandshakeMode = s}) getTLS13HandshakeMode :: HandshakeM HandshakeMode13 getTLS13HandshakeMode = gets hstTLS13HandshakeMode@@ -317,76 +347,106 @@ deriving (Show, Eq) setTLS13RTT0Status :: RTT0Status -> HandshakeM ()-setTLS13RTT0Status s = modify (\hst -> hst{hstTLS13RTT0Status = s})+setTLS13RTT0Status s = modify' (\hst -> hst{hstTLS13RTT0Status = s}) getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM ()-setTLS13EarlySecret secret = modify (\hst -> hst{hstTLS13EarlySecret = Just secret})+setTLS13EarlySecret secret = modify' (\hst -> hst{hstTLS13EarlySecret = Just secret}) getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) getTLS13EarlySecret = gets hstTLS13EarlySecret setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM ()-setTLS13ResumptionSecret secret = modify (\hst -> hst{hstTLS13ResumptionSecret = Just secret})+setTLS13ResumptionSecret secret = modify' (\hst -> hst{hstTLS13ResumptionSecret = Just secret}) getTLS13ResumptionSecret :: HandshakeM (Maybe (BaseSecret ResumptionSecret)) getTLS13ResumptionSecret = gets hstTLS13ResumptionSecret setTLS13CertComp :: Bool -> HandshakeM ()-setTLS13CertComp comp = modify (\hst -> hst{hstTLS13CertComp = comp})+setTLS13CertComp comp = modify' (\hst -> hst{hstTLS13CertComp = comp}) getTLS13CertComp :: HandshakeM Bool getTLS13CertComp = gets hstTLS13CertComp setCCS13Sent :: Bool -> HandshakeM ()-setCCS13Sent sent = modify (\hst -> hst{hstCCS13Sent = sent})+setCCS13Sent sent = modify' (\hst -> hst{hstCCS13Sent = sent}) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent setCCS13Recv :: Bool -> HandshakeM ()-setCCS13Recv sent = modify (\hst -> hst{hstCCS13Recv = sent})+setCCS13Recv sent = modify' (\hst -> hst{hstCCS13Recv = sent}) getCCS13Recv :: HandshakeM Bool getCCS13Recv = gets hstCCS13Recv setCertReqSent :: Bool -> HandshakeM ()-setCertReqSent b = modify (\hst -> hst{hstCertReqSent = b})+setCertReqSent b = modify' (\hst -> hst{hstCertReqSent = b}) getCertReqSent :: HandshakeM Bool getCertReqSent = gets hstCertReqSent setClientCertSent :: Bool -> HandshakeM ()-setClientCertSent b = modify (\hst -> hst{hstClientCertSent = b})+setClientCertSent b = modify' (\hst -> hst{hstClientCertSent = b}) +getClientRandom :: HandshakeM ClientRandom+getClientRandom = gets hstClientRandom++setClientRandom :: ClientRandom -> HandshakeM ()+setClientRandom cr = modify' $ \hst -> hst{hstClientRandom = cr}++getOuterClientRandom :: HandshakeM (Maybe ClientRandom)+getOuterClientRandom = gets hstTLS13OuterClientRandom++setOuterClientRandom :: Maybe ClientRandom -> HandshakeM ()+setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr})++getClientHello :: HandshakeM (Maybe ClientHello)+getClientHello = gets hstTLS13ClientHello++setClientHello :: ClientHello -> HandshakeM ()+setClientHello ch = modify' $ \hst -> hst{hstTLS13ClientHello = Just ch}++getECHAccepted :: HandshakeM Bool+getECHAccepted = gets hstTLS13ECHAccepted++setECHAccepted :: Bool -> HandshakeM ()+setECHAccepted b = modify' $ \hst -> hst{hstTLS13ECHAccepted = b}++getECHEE :: HandshakeM Bool+getECHEE = gets hstTLS13ECHEE++setECHEE :: Bool -> HandshakeM ()+setECHEE b = modify' $ \hst -> hst{hstTLS13ECHEE = b}+ getClientCertSent :: HandshakeM Bool getClientCertSent = gets hstClientCertSent setClientCertChain :: CertificateChain -> HandshakeM ()-setClientCertChain b = modify (\hst -> hst{hstClientCertChain = Just b})+setClientCertChain b = modify' (\hst -> hst{hstClientCertChain = Just b}) getClientCertChain :: HandshakeM (Maybe CertificateChain) getClientCertChain = gets hstClientCertChain -- setCertReqToken :: Maybe ByteString -> HandshakeM ()-setCertReqToken token = modify $ \hst -> hst{hstCertReqToken = token}+setCertReqToken token = modify' $ \hst -> hst{hstCertReqToken = token} getCertReqToken :: HandshakeM (Maybe ByteString) getCertReqToken = gets hstCertReqToken -- setCertReqCBdata :: Maybe CertReqCBdata -> HandshakeM ()-setCertReqCBdata d = modify (\hst -> hst{hstCertReqCBdata = d})+setCertReqCBdata d = modify' (\hst -> hst{hstCertReqCBdata = d}) getCertReqCBdata :: HandshakeM (Maybe CertReqCBdata) getCertReqCBdata = gets hstCertReqCBdata -- Dead code, until we find some use for the extension setCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] -> HandshakeM ()-setCertReqSigAlgsCert as = modify $ \hst -> hst{hstCertReqSigAlgsCert = as}+setCertReqSigAlgsCert as = modify' $ \hst -> hst{hstCertReqSigAlgsCert = as} getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert@@ -396,63 +456,11 @@ getPendingCipher = fromJust <$> gets hstPendingCipher addHandshakeMessage :: ByteString -> HandshakeM ()-addHandshakeMessage content = modify $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs}+addHandshakeMessage content = modify' $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) -getHandshakeMessagesRev :: HandshakeM [ByteString]-getHandshakeMessagesRev = gets hstHandshakeMessages--updateHandshakeDigest :: ByteString -> HandshakeM ()-updateHandshakeDigest content = modify $ \hs ->- hs- { hstHandshakeDigest = case hstHandshakeDigest hs of- HandshakeMessages bytes -> HandshakeMessages (content : bytes)- HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content- }---- | Compress the whole transcript with the specified function. Function @f@--- takes the handshake digest as input and returns an encoded handshake message--- to replace the transcript with.-foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM ()-foldHandshakeDigest hashAlg f = modify $ \hs ->- case hstHandshakeDigest hs of- HandshakeMessages bytes ->- let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes- folded = f (hashFinal hashCtx)- in hs- { hstHandshakeDigest = HandshakeMessages [folded]- , hstHandshakeMessages = [folded]- }- HandshakeDigestContext hashCtx ->- let folded = f (hashFinal hashCtx)- hashCtx' = hashUpdate (hashInit hashAlg) folded- in hs- { hstHandshakeDigest = HandshakeDigestContext hashCtx'- , hstHandshakeMessages = [folded]- }--getSessionHash :: HandshakeM ByteString-getSessionHash = gets $ \hst ->- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized session hash"--getHandshakeDigest :: Version -> Role -> HandshakeM ByteString-getHandshakeDigest ver role = gets gen- where- gen hst = case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx ->- let msecret = fromJust $ hstMainSecret hst- cipher = fromJust $ hstPendingCipher hst- in generateFinished ver cipher msecret hashCtx- HandshakeMessages _ ->- error "un-initialized handshake digest"- generateFinished- | role == ClientRole = generateClientFinished- | otherwise = generateServerFinished- -- | Generate the main secret from the pre-main secret. setMainSecretFromPre :: ByteArrayAccess preMain@@ -483,10 +491,16 @@ preMainSecret <$> getSessionHash +getSessionHash :: HandshakeM ByteString+getSessionHash = gets $ \hst ->+ case hstTransHashState hst of+ TransHashState2 hashCtx -> hashFinal hashCtx+ _ -> error "un-initialized session hash"+ -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. setMainSecret :: Version -> Role -> ByteString -> HandshakeM ()-setMainSecret ver role mainSecret = modify $ \hst ->+setMainSecret ver role mainSecret = modify' $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role in hst { hstMainSecret = Just mainSecret@@ -554,31 +568,3 @@ } orOnServer f g = if cc == ClientRole then f else g--setServerHelloParameters- :: Version- -- ^ chosen version- -> ServerRandom- -> Cipher- -> Compression- -> HandshakeM ()-setServerHelloParameters ver sran cipher compression = do- modify $ \hst ->- hst- { hstServerRandom = Just sran- , hstPendingCipher = Just cipher- , hstPendingCompression = compression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- where- hashAlg = getHash ver cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384--- instead of the default SHA256.-getHash :: Version -> Cipher -> Hash-getHash ver ciph- | ver < TLS12 = SHA1_MD5- | maybe True (< TLS12) (cipherMinVer ciph) = SHA256- | otherwise = cipherHash ciph
Network/TLS/Handshake/State13.hs view
@@ -15,28 +15,20 @@ getRxLevel, clearTxRecordState, clearRxRecordState,- setHelloParameters13,- transcriptHash,- wrapAsMessageHash13, PendingRecvAction (..), setPendingRecvActions, popPendingRecvAction, ) where import Control.Concurrent.MVar-import Control.Monad.State-import qualified Data.ByteString as B import Data.IORef import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal-import Network.TLS.Crypto-import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State-import Network.TLS.Struct import Network.TLS.Types getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)@@ -145,51 +137,6 @@ clearXState :: (Context -> MVar RecordState) -> Context -> IO () clearXState func ctx = modifyMVar_ (func ctx) (\rt -> return rt{stCipher = Nothing})--setHelloParameters13 :: Cipher -> HandshakeM (Either TLSError ())-setHelloParameters13 cipher = do- hst <- get- case hstPendingCipher hst of- Nothing -> do- put- hst- { hstPendingCipher = Just cipher- , hstPendingCompression = nullCompression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- return $ Right ()- Just oldcipher- | cipher == oldcipher -> return $ Right ()- | otherwise ->- return $- Left $- Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter- where- hashAlg = cipherHash cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- When a HelloRetryRequest is sent or received, the existing transcript must be--- wrapped in a "message_hash" construct. See RFC 8446 section 4.4.1. This--- applies to key-schedule computations as well as the ones for PSK binders.-wrapAsMessageHash13 :: HandshakeM ()-wrapAsMessageHash13 = do- cipher <- getPendingCipher- foldHandshakeDigest (cipherHash cipher) foldFunc- where- foldFunc dig =- B.concat- [ "\254\0\0"- , B.singleton (fromIntegral $ B.length dig)- , dig- ]--transcriptHash :: MonadIO m => Context -> m ByteString-transcriptHash ctx = do- hst <- fromJust <$> getHState ctx- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized handshake digest" setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx)
+ Network/TLS/Handshake/TranscriptHash.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.TranscriptHash (+ transcriptHash,+ transcriptHashWith,+ transitTranscriptHashI,+ updateTranscriptHash,+ updateTranscriptHashI,+ transitTranscriptHash,+ copyTranscriptHash,+ TranscriptHash (..),+) where++import Control.Monad.State+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Types++----------------------------------------------------------------++transitTranscriptHash :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHash ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = transit label hashAlg isHRR $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++transitTranscriptHashI :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHashI ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = transit label hashAlg isHRR $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++transit :: String -> Hash -> Bool -> TransHashState -> TransHashState+transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0+transit _ _ _ st2@(TransHashState2 _) = st2+transit _ hashAlg isHRR (TransHashState1 ch)+ | isHRR = TransHashState2 $ newWith hsMsg+ | otherwise = TransHashState2 $ newWith ch+ where+ newWith = hashUpdate $ hashInit hashAlg+ hsMsg =+ -- Handshake message:+ -- typ <-len-> body+ -- 254 0 0 len hash(CH1)+ B.concat+ [ "\254\0\0"+ , B.singleton len+ , hashedCH+ ]+ where+ hashedCH = hash hashAlg ch+ len = fromIntegral $ B.length hashedCH++----------------------------------------------------------------++updateTranscriptHash :: Context -> String -> ByteString -> IO ()+updateTranscriptHash ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = update eh label $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++updateTranscriptHashI :: Context -> String -> ByteString -> IO ()+updateTranscriptHashI ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = update eh label $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++update :: ByteString -> String -> TransHashState -> TransHashState+update eh _ TransHashState0 = TransHashState1 eh+update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh+update _ label st = error $ "updateTranscriptHash " ++ label ++ " " ++ show st++----------------------------------------------------------------++transcriptHash :: MonadIO m => Context -> String -> m TranscriptHash+transcriptHash ctx label = do+ hst <- fromJust <$> getHState ctx+ let th = calc label $ hstTransHashState hst+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calc :: String -> TransHashState -> ByteString+calc _ (TransHashState2 hashCtx) = hashFinal hashCtx+calc label st = error $ "transcriptHash " ++ label ++ " " ++ show st++----------------------------------------------------------------++transcriptHashWith+ :: MonadIO m => Context -> String -> ByteString -> m TranscriptHash+transcriptHashWith ctx label bs = do+ role <- liftIO $ usingState_ ctx getRole+ let isClient = role == ClientRole+ hst <- fromJust <$> getHState ctx+ let st+ | isClient = hstTransHashStateI hst+ | otherwise = hstTransHashState hst+ let th = calcWith bs label st+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calcWith :: ByteString -> String -> TransHashState -> ByteString+calcWith bs _ (TransHashState2 hashCtx) = hashFinal $ hashUpdate hashCtx bs+calcWith _ label st = error $ "transcriptHashWith " ++ label ++ " " ++ show st++----------------------------------------------------------------++copyTranscriptHash :: Context -> String -> IO ()+copyTranscriptHash ctx label = do+ usingHState ctx $ modify' $ \hst ->+ hst+ { hstTransHashState = hstTransHashStateI hst+ }+ traceTranscriptHash ctx label hstTransHashState++----------------------------------------------------------------++traceTranscriptHash+ :: Context -> String -> (HandshakeState -> TransHashState) -> IO ()+traceTranscriptHash ctx label getField = do+ hst <- fromJust <$> getHState ctx+ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ show (getField hst)++adjustLabel :: String -> String+adjustLabel label = take 24 (label ++ " ")
Network/TLS/Hooks.hs view
@@ -5,8 +5,9 @@ defaultHooks, ) where -import qualified Data.ByteString as B import Data.Default (Default (def))++import Network.TLS.Imports import Network.TLS.Struct (Handshake, Header) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain)@@ -17,8 +18,8 @@ data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO ()- , loggingIOSent :: B.ByteString -> IO ()- , loggingIORecv :: Header -> B.ByteString -> IO ()+ , loggingIOSent :: ByteString -> IO ()+ , loggingIORecv :: Header -> ByteString -> IO () } defaultLogging :: Logging
Network/TLS/IO.hs view
@@ -38,9 +38,10 @@ -- | Send one packet to the context sendPacket12 :: Context -> Packet -> IO () sendPacket12 ctx@Context{ctxRecordLayer = recordLayer} pkt = do- -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is sent before a normal data packet, to- -- prevent guessability.+ -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue+ -- as IV, which can be guessed by an attacker. Hence, an empty+ -- packet is sent before a normal data packet, to prevent+ -- guessability. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $@@ -193,9 +194,9 @@ isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do- cont <- gets stHandshakeRecordCont+ cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13- return $ isNothing cont && isNothing cont13+ return $ isNothing cont12 && isNothing cont13 checkValid :: Context -> IO () checkValid ctx = do@@ -234,4 +235,4 @@ (recordLayer, ref) <- ask liftIO $ do bs <- writePacketBytes13 ctx recordLayer pkt- modifyIORef ref (. (bs :))+ modifyIORef' ref (. (bs :))
Network/TLS/IO/Decode.hs view
@@ -41,8 +41,8 @@ , cParamsKeyXchgType = keyxchg } -- get back the optional continuation, and parse as many handshake record as possible.- mCont <- gets stHandshakeRecordCont- modify (\st -> st{stHandshakeRecordCont = Nothing})+ mCont <- gets stHandshakeRecordCont12+ modify' (\st -> st{stHandshakeRecordCont12 = Nothing}) hss <- parseMany currentParams mCont (fragmentGetBytes fragment) return $ Handshake hss where@@ -50,7 +50,7 @@ case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont = Just cont}) >> return []+ modify' (\st -> st{stHandshakeRecordCont12 = Just cont}) >> return [] GotSuccess (ty, content) -> either throwError (return . (: [])) $ decodeHandshake currentParams ty content GotSuccessRemaining (ty, content) left ->@@ -75,7 +75,7 @@ decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do mCont <- gets stHandshakeRecordCont13- modify (\st -> st{stHandshakeRecordCont13 = Nothing})+ modify' (\st -> st{stHandshakeRecordCont13 = Nothing}) hss <- parseMany mCont (fragmentGetBytes fragment) return $ Handshake13 hss where@@ -83,7 +83,7 @@ case fromMaybe decodeHandshakeRecord13 mCont bs of GotError err -> throwError err GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []+ modify' (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return [] GotSuccess (ty, content) -> either throwError (return . (: [])) $ decodeHandshake13 ty content GotSuccessRemaining (ty, content) left ->
Network/TLS/IO/Encode.hs view
@@ -1,8 +1,8 @@ module Network.TLS.IO.Encode ( encodePacket12, encodePacket13,- updateHandshake12,- updateHandshake13,+ updateTranscriptHash12,+ updateTranscriptHash13, ) where import Control.Concurrent.MVar@@ -13,7 +13,7 @@ import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Packet13@@ -48,7 +48,7 @@ -- empty-packet countermeasure may be applied to each fragment independently. packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString] packetToFragments12 ctx mlen (Handshake hss) =- getChunks mlen . B.concat <$> mapM (updateHandshake12 ctx) hss+ getChunks mlen . B.concat <$> mapM (updateTranscriptHash12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x]@@ -73,11 +73,13 @@ where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) -updateHandshake12 :: Context -> Handshake -> IO ByteString-updateHandshake12 ctx hs = do- usingHState ctx $ do- when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded- when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded+updateTranscriptHash12 :: Context -> Handshake -> IO ByteString+updateTranscriptHash12 ctx hs = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ addHandshakeMessage encoded+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded return encoded where encoded = encodeHandshake hs@@ -99,24 +101,21 @@ packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString] packetToFragments13 ctx mlen (Handshake13 hss) =- getChunks mlen . B.concat <$> mapM (updateHandshake13 ctx) hss+ getChunks mlen . B.concat <$> mapM (updateTranscriptHash13 ctx) hss packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments13 _ _ (AppData13 x) = return [x] packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] -updateHandshake13 :: Context -> Handshake13 -> IO ByteString-updateHandshake13 ctx hs+updateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString+updateTranscriptHash13 ctx hs | isIgnored hs = return encoded- | otherwise = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ updateTranscriptHash ctx label encoded+ usingHState ctx $ addHandshakeMessage encoded return encoded where encoded = encodeHandshake13 hs-- isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand- isHRR _ = False isIgnored NewSessionTicket13{} = True isIgnored KeyUpdate13{} = True
Network/TLS/Imports.hs view
@@ -16,22 +16,18 @@ showBytesHex, ) where -import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()---- instance-import Data.Functor- import Control.Applicative import Control.Monad import Data.Bits+import Data.ByteArray.Encoding as B+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Functor import Data.List import Data.Maybe import Data.Ord import Data.Semigroup import Data.Word--import Data.ByteArray.Encoding as B import qualified Prelude as P showBytesHex :: ByteString -> P.String
Network/TLS/KeySchedule.hs view
@@ -10,8 +10,10 @@ import Crypto.KDF.HKDF import Data.ByteArray (convert) import qualified Data.ByteString as BS+ import Network.TLS.Crypto import Network.TLS.Imports+import Network.TLS.Types import Network.TLS.Wire ----------------------------------------------------------------@@ -27,8 +29,8 @@ ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString-deriveSecret h secret label hashedMsgs =+deriveSecret :: Hash -> ByteString -> ByteString -> TranscriptHash -> ByteString+deriveSecret h secret label (TranscriptHash hashedMsgs) = hkdfExpandLabel h secret label hashedMsgs outlen where outlen = hashDigestSize h
Network/TLS/MAC.hs view
@@ -10,6 +10,7 @@ import qualified Data.ByteArray as B (xor) import qualified Data.ByteString as B+ import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types
Network/TLS/Packet.hs view
@@ -21,7 +21,9 @@ decodeHandshakeRecord, decodeHandshake, encodeHandshake,+ encodeHandshake', encodeCertificate,+ decodeClientHello', -- * marshall functions for change cipher spec message decodeChangeCipherSpec,@@ -36,8 +38,6 @@ generateMainSecret, generateExtendedMainSecret, generateKeyBlock,- generateClientFinished,- generateServerFinished, -- * for extensions parsing getSignatureHashAlgorithm,@@ -55,6 +55,10 @@ putDNames, getDNames, getHandshakeType,++ -- * PRF+ PRF,+ getPRF, ) where import Data.ByteArray (ByteArrayAccess)@@ -162,7 +166,7 @@ :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest- HandshakeType_ClientHello -> decodeClientHello+ HandshakeType_ClientHello -> decodeClientHello False HandshakeType_ServerHello -> decodeServerHello HandshakeType_NewSessionTicket -> decodeNewSessionTicket HandshakeType_Certificate -> decodeCertificate@@ -178,8 +182,11 @@ decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest -decodeClientHello :: Get Handshake-decodeClientHello = do+decodeClientHello' :: ByteString -> Either TLSError Handshake+decodeClientHello' = runGetErr "decodeClientHello'" $ decodeClientHello True++decodeClientHello :: Bool -> Get Handshake+decodeClientHello inner = do ver <- getBinaryVersion random <- getClientRandom32 session <- getSession@@ -191,9 +198,26 @@ then getWord16 >>= getExtensions . fromIntegral else return [] r1 <- remaining- when (r1 /= 0) $ fail "Client hello"- let ch = CH session ciphers exts- return $ ClientHello ver random compressions ch+ if inner+ then+ checkAndSkip r1+ else when (r1 /= 0) $ fail "Client hello has garbage"+ return $+ ClientHello $+ CH+ { chVersion = ver+ , chRandom = random+ , chSession = session+ , chCiphers = ciphers+ , chComps = compressions+ , chExtensions = exts+ }+ where+ checkAndSkip 0 = return ()+ checkAndSkip r = do+ zero <- getWord8+ when (zero /= 0) $ fail "Inner client hello has garbage"+ checkAndSkip (r - 1) decodeServerHello :: Get Handshake decodeServerHello = do@@ -207,7 +231,16 @@ if r > 0 then getWord16 >>= getExtensions . fromIntegral else return []- return $ ServerHello ver random session cipherid compressionid exts+ return $+ ServerHello $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = compressionid+ , shExtensions = exts+ } decodeNewSessionTicket :: Get Handshake decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16@@ -219,7 +252,7 @@ <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)- Right cc -> return $ Certificate $ TLSCertificateChain cc+ Right cc -> return $ Certificate $ CertificateChain_ cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) @@ -326,26 +359,24 @@ encodeHandshake' :: Handshake -> ByteString encodeHandshake' HelloRequest = ""-encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do- putBinaryVersion version- putClientRandom32 random+encodeHandshake' (ClientHello CH{..}) = runPut $ do+ putBinaryVersion chVersion+ putClientRandom32 chRandom putSession chSession putWords16 $ map fromCipherId chCiphers- putWords8 compressionIDs+ putWords8 chComps putExtensions chExtensions- return ()-encodeHandshake' (ServerHello version random session cipherid compressionID exts) = runPut $ do- putBinaryVersion version- putServerRandom32 random- putSession session- putWord16 $ fromCipherId cipherid- putWord8 compressionID- putExtensions exts- return ()+encodeHandshake' (ServerHello SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions encodeHandshake' (NewSessionTicket life ticket) = runPut $ do putWord32 life putOpaque16 ticket-encodeHandshake' (Certificate (TLSCertificateChain cc)) = encodeCertificate cc+encodeHandshake' (Certificate (CertificateChain_ cc)) = encodeCertificate cc encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented"@@ -585,29 +616,6 @@ -> Int -> ByteString generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c--generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString-generateFinished_TLS prf label mainSecret hashctx = prf mainSecret seed 12- where- seed = B.concat [label, hashFinal hashctx]--generateClientFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateClientFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "client finished"--generateServerFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateServerFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "server finished" ------------------------------------------------------------
Network/TLS/Packet13.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Packet13 ( encodeHandshake13,@@ -19,6 +20,8 @@ decodeCertificateChain, encodeCertificateChain, )+import System.IO.Unsafe+ import Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.Packet@@ -26,7 +29,6 @@ import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire-import System.IO.Unsafe ---------------------------------------------------------------- @@ -44,22 +46,29 @@ putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString-encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do- putBinaryVersion TLS12- putServerRandom32 random- putSession session- putWord16 $ fromCipherId cipherId- putWord8 0 -- compressionID nullCompression- putExtensions exts-encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do- putWord32 life- putWord32 ageadd- putOpaque8 nonce- putOpaque16 label- putExtensions exts+encodeHandshake13' (ServerHello13 SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions+encodeHandshake13'+ ( NewSessionTicket13+ life+ ageadd+ (TicketNonce nonce)+ (SessionIDorTicket_ label)+ exts+ ) = runPut $ do+ putWord32 life+ putWord32 ageadd+ putOpaque8 nonce+ putOpaque16 label+ putExtensions exts encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts-encodeHandshake13' (Certificate13 reqctx (TLSCertificateChain cc) ess) = encodeCertificate13 reqctx cc ess+encodeHandshake13' (Certificate13 reqctx (CertificateChain_ cc) ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts@@ -69,7 +78,7 @@ encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1-encodeHandshake13' (CompressedCertificate13 reqctx (TLSCertificateChain cc) ess) = runPut $ do+encodeHandshake13' (CompressedCertificate13 reqctx (CertificateChain_ cc) ess) = runPut $ do putWord16 1 -- zlib: fixme let bs = encodeCertificate13 reqctx cc ess putWord24 $ fromIntegral $ B.length bs@@ -129,20 +138,29 @@ decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do- _ver <- getBinaryVersion+ ver <- getBinaryVersion random <- getServerRandom32 session <- getSession cipherid <- CipherId <$> getWord16- _comp <- getWord8+ comp <- getWord8 exts <- getWord16 >>= getExtensions . fromIntegral- return $ ServerHello13 random session cipherid exts+ return $+ ServerHello13 $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = comp+ , shExtensions = exts+ } decodeNewSessionTicket13 :: Get Handshake13 decodeNewSessionTicket13 = do life <- getWord32 ageadd <- getWord32- nonce <- getOpaque8- label <- getOpaque16+ nonce <- TicketNonce <$> getOpaque8+ label <- SessionIDorTicket_ <$> getOpaque16 len <- fromIntegral <$> getWord16 exts <- getExtensions len return $ NewSessionTicket13 life ageadd nonce label exts@@ -160,7 +178,7 @@ (certRaws, ess) <- unzip <$> getList len getCert case decodeCertificateChain $ CertificateChainRaw certRaws of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s)- Right cc -> return $ Certificate13 reqctx (TLSCertificateChain cc) ess+ Right cc -> return $ Certificate13 reqctx (CertificateChain_ cc) ess where getCert = do l <- fromIntegral <$> getWord24
Network/TLS/Parameters.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE Strict #-}+ module Network.TLS.Parameters ( ClientParams (..), defaultParamsClient,@@ -28,12 +30,14 @@ Information (..), ) where -import qualified Data.ByteString as B+import Crypto.HPKE import Data.Default (Default (def))+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto+import Network.TLS.ECH.Config import Network.TLS.Extension import Network.TLS.Extra.Cipher import Network.TLS.Handshake.State@@ -69,6 +73,8 @@ -- ^ Printing main keys. -- -- Default: no printing+ , debugError :: String -> IO ()+ , debugTraceKey :: String -> IO () } -- | Default value for 'DebugParams'@@ -78,7 +84,9 @@ { debugSeed = Nothing , debugPrintSeed = const (return ()) , debugVersionForced = Nothing- , debugKeyLogger = \_ -> return ()+ , debugKeyLogger = \ ~_ -> return ()+ , debugError = \ ~_ -> return ()+ , debugTraceKey = \ ~_ -> return () } instance Show DebugParams where@@ -94,34 +102,37 @@ -- -- Default: 'Nothing' , clientServerIdentification :: (HostName, ByteString)- -- ^ Define the name of the server, along with an extra service identification blob.- -- this is important that the hostname part is properly filled for security reason,- -- as it allow to properly associate the remote side with the given certificate- -- during a handshake.+ -- ^ Define the name of the server, along with an extra service+ -- identification blob. this is important that the hostname part+ -- is properly filled for security reason, as it allow to properly+ -- associate the remote side with the given certificate during a+ -- handshake. --- -- The extra blob is useful to differentiate services running on the same host, but that- -- might have different certificates given. It's only used as part of the X509 validation+ -- The extra blob is useful to differentiate services running on+ -- the same host, but that might have different certificates+ -- given. It's only used as part of the X509 validation -- infrastructure. -- -- This value is typically set by 'defaultParamsClient'. , clientUseServerNameIndication :: Bool- -- ^ Allow the use of the Server Name Indication TLS extension during handshake, which allow- -- the client to specify which host name, it's trying to access. This is useful to distinguish+ -- ^ Allow the use of the Server Name Indication TLS extension+ -- during handshake, which allow the client to specify which host+ -- name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). -- -- Default: 'True' , clientWantSessionResume :: Maybe (SessionID, SessionData)- -- ^ 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.+ -- ^ 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.+ -- 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@@ -129,19 +140,28 @@ , clientHooks :: ClientHooks -- ^ See the default value of 'ClientHooks'. , clientSupported :: Supported- -- ^ In this element, you'll need to override the default empty value of- -- of 'supportedCiphers' with a suitable cipherlist.+ -- ^ In this element, you'll need to override the default empty+ -- value of of 'supportedCiphers' with a suitable cipherlist. -- -- See the default value of 'Supported'. , clientDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , clientUseEarlyData :: Bool- -- ^ Client tries to send early data in TLS 1.3- -- via 'sendData' if possible.- -- If not accepted by the server, the early data- -- is automatically re-sent.+ -- ^ Client tries to send early data in TLS 1.3 via 'sendData' if+ -- possible. If not accepted by the server, the early data is+ -- automatically re-sent. -- -- Default: 'False'+ , clientUseECH :: Bool+ -- ^ Enabling Encrypted Client Hello.+ -- If 'sharedECHConfigList' is null, a greasing ECH extension is sent.+ -- Otherwise, a valid ECH is sent.+ -- If the server rejects ECH in Server Hello,+ -- the client sends an alert after negotiation.+ --+ -- Default: 'False'+ --+ -- @since 2.1.9 } deriving (Show) @@ -159,6 +179,7 @@ , clientSupported = def , clientDebug = defaultDebugParams , clientUseEarlyData = False+ , clientUseECH = False } data ServerParams = ServerParams@@ -167,15 +188,15 @@ -- -- Default: 'False' , serverCACertificates :: [SignedCertificate]- -- ^ This is a list of certificates from which the- -- disinguished names are sent in certificate request- -- messages. For TLS1.0, it should not be empty.+ -- ^ This is a list of certificates from which the disinguished+ -- names are sent in certificate request messages. For TLS1.0, it+ -- should not be empty. -- -- Default: '[]' , serverDHEParams :: Maybe DHParams- -- ^ Server Optional Diffie Hellman parameters. Setting parameters is- -- necessary for FFDHE key exchange when clients are not compatible- -- with RFC 7919.+ -- ^ Server Optional Diffie Hellman parameters. Setting+ -- parameters is necessary for FFDHE key exchange when clients are+ -- not compatible with RFC 7919. -- -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with@@ -191,16 +212,21 @@ , serverDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , serverEarlyDataSize :: Int- -- ^ Server accepts this size of early data in TLS 1.3.- -- 0 (or lower) means that the server does not accept early data.+ -- ^ Server accepts this size of early data in TLS 1.3. 0 (or+ -- lower) means that the server does not accept early data. -- -- Default: 0 , serverTicketLifetime :: Int- -- ^ Lifetime in seconds for session tickets generated by the server.- -- Acceptable value range is 0 to 604800 (7 days).+ -- ^ Lifetime in seconds for session tickets generated by the+ -- server. Acceptable value range is 0 to 604800 (7 days). -- -- Default: 7200 (2 hours)- , serverLimit :: Limit+ , serverECHKey :: [(ConfigId, ByteString)]+ -- ^ ECH secret keys.+ --+ -- Default: '[]'+ --+ -- @since 2.1.9 } deriving (Show) @@ -216,7 +242,7 @@ , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 7200- , serverLimit = defaultLimit+ , serverECHKey = [] } instance Default ServerParams where@@ -225,26 +251,27 @@ -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported { supportedVersions :: [Version]- -- ^ Supported versions by this context. On the client side, the highest- -- version will be used to establish the connection. On the server side,- -- the highest version that is less or equal than the client version will- -- be chosen.+ -- ^ Supported versions by this context. On the client side, the+ -- highest version will be used to establish the connection. On+ -- the server side, the highest version that is less or equal than+ -- the client version will be chosen. --- -- Versions should be listed in preference order, i.e. higher versions- -- first.+ -- Versions should be listed in preference order, i.e. higher+ -- versions first. -- -- Default: @[TLS13,TLS12]@ , supportedCiphers :: [Cipher]- -- ^ Supported cipher methods. The default is empty, specify a suitable- -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often- -- a good choice.+ -- ^ Supported cipher methods. The default is empty, specify a+ -- suitable cipher list.+ -- 'Network.TLS.Extra.Cipher.ciphersuite_default' is often a good+ -- choice. -- -- Default: @[]@ , supportedCompressions :: [Compression] -- ^ Supported compressions methods. By default only the "null"- -- compression is supported, which means no compression will be performed.- -- Allowing other compression method is not advised as it causes a- -- connection failure when TLS 1.3 is negotiated.+ -- compression is supported, which means no compression will be+ -- performed. Allowing other compression method is not advised as+ -- it causes a connection failure when TLS 1.3 is negotiated. -- -- Default: @[nullCompression]@ , supportedHashSignatures :: [HashAndSignatureAlgorithm]@@ -252,18 +279,19 @@ -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. --- -- This list is sent to the peer as part of the "signature_algorithms"- -- extension. It is used to restrict accepted signatures received from- -- the peer at TLS level (not in X.509 certificates), but only when the- -- TLS version is 1.2 or above. In order to disable SHA-1 one must then- -- also disable earlier protocol versions in 'supportedVersions'.+ -- This list is sent to the peer as part of the+ -- "signature_algorithms" extension. It is used to restrict+ -- accepted signatures received from the peer at TLS level (not in+ -- X.509 certificates), but only when the TLS version is 1.2 or+ -- above. In order to disable SHA-1 one must then also disable+ -- earlier protocol versions in 'supportedVersions'. -- -- The list also impacts the selection of possible algorithms when -- generating signatures. --- -- Note: with TLS 1.3 some algorithms have been deprecated and will not be- -- used even when listed in the parameter: MD5, SHA-1, SHA-224, RSA- -- PKCS#1, DSA.+ -- Note: with TLS 1.3 some algorithms have been deprecated and+ -- will not be used even when listed in the parameter: MD5, SHA-1,+ -- SHA-224, RSA PKCS#1, DSA. -- -- Default: --@@ -284,62 +312,67 @@ -- ] -- @ , supportedSecureRenegotiation :: Bool- -- ^ Secure renegotiation defined in RFC5746.- -- If 'True', clients send the renegotiation_info extension.- -- If 'True', servers handle the extension or the renegotiation SCSV- -- then send the renegotiation_info extension.+ -- ^ Secure renegotiation defined in RFC5746. If 'True', clients+ -- send the renegotiation_info extension. If 'True', servers+ -- handle the extension or the renegotiation SCSV then send the+ -- renegotiation_info extension. -- -- Default: 'True' , supportedClientInitiatedRenegotiation :: Bool -- ^ If 'True', renegotiation is allowed from the client side.- -- This is vulnerable to DOS attacks.- -- If 'False', renegotiation is allowed only from the server side- -- via HelloRequest.+ -- This is vulnerable to DOS attacks. If 'False', renegotiation+ -- is allowed only from the server side via HelloRequest. -- -- Default: 'False' , supportedExtendedMainSecret :: EMSMode- -- ^ The mode regarding extended main secret. Enabling this extension- -- provides better security for TLS versions 1.2. TLS 1.3 provides- -- the security properties natively and does not need the extension.- --- -- By default the extension is 'RequireEMS'.- -- So, the handshake will fail when the peer does not support+ -- ^ The mode regarding extended main secret. Enabling this+ -- extension provides better security for TLS versions 1.2. TLS+ -- 1.3 provides the security properties natively and does not need -- the extension. --+ -- By default the extension is 'RequireEMS'. So, the handshake+ -- will fail when the peer does not support the extension.+ -- -- Default: 'RequireEMS' , supportedSession :: Bool -- ^ Set if we support session. -- -- Default: 'True' , supportedFallbackScsv :: Bool- -- ^ Support for fallback SCSV defined in RFC7507.- -- If 'True', servers reject handshakes which suggest- -- a lower protocol than the highest protocol supported.+ -- ^ Support for fallback SCSV defined in RFC7507. If 'True',+ -- servers reject handshakes which suggest a lower protocol than+ -- the highest protocol supported. -- -- Default: 'True' , supportedEmptyPacket :: Bool- -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to- -- prevent guessability. Some Microsoft TLS-based protocol implementations, however,- -- consider these empty packets as a protocol violation and disconnect. If this parameter is- -- 'False', empty packets will never be added, which is less secure, but might help in rare- -- cases.+ -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC+ -- residue as IV, which can be guessed by an attacker. Hence, an+ -- empty packet is normally sent before a normal data packet, to+ -- prevent guessability. Some Microsoft TLS-based protocol+ -- implementations, however, consider these empty packets as a+ -- protocol violation and disconnect. If this parameter is+ -- 'False', empty packets will never be added, which is less+ -- secure, but might help in rare cases. -- -- Default: 'True' , supportedGroups :: [Group]- -- ^ A list of supported elliptic curves and finite-field groups in the- -- preferred order.+ -- ^ A list of supported elliptic curves and finite-field groups+ -- in the preferred order. --- -- The list is sent to the server as part of the "supported_groups"- -- extension. It is used in both clients and servers to restrict- -- accepted groups in DH key exchange. Up until TLS v1.2, it is also- -- used by a client to restrict accepted elliptic curves in ECDSA- -- signatures.+ -- The list is sent to the server as part of the+ -- "supported_groups" extension. It is used in both clients and+ -- servers to restrict accepted groups in DH key exchange. Up+ -- until TLS v1.2, it is also used by a client to restrict+ -- accepted elliptic curves in ECDSA signatures. --- -- The default value includes all groups with security strength of 128- -- bits or more.+ -- The default value includes all groups with security strength+ -- of 128 bits or more. -- -- Default: @[X25519,X448,P256,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@+ , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -- ^ Client only.+ --+ -- @since 2.1.9 } deriving (Show, Eq) @@ -353,6 +386,16 @@ RequireEMS deriving (Show, Eq) +defaultHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+defaultHPKE =+ [ (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA512, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P521_HKDF_SHA512, HKDF_SHA512, AES_256_GCM)+ ]+ defaultSupported :: Supported defaultSupported = Supported@@ -367,6 +410,7 @@ , supportedFallbackScsv = True , supportedEmptyPacket = True , supportedGroups = supportedNamedGroups+ , supportedHPKE = defaultHPKE } instance Default Supported where@@ -375,11 +419,11 @@ -- | Parameters that are common to clients and servers. data Shared = Shared { sharedCredentials :: Credentials- -- ^ The list of certificates and private keys that a server will use as- -- part of authentication to clients. Actual credentials that are used- -- are selected dynamically from this list based on client capabilities.- -- Additional credentials returned by 'onServerNameIndication' are also- -- considered.+ -- ^ The list of certificates and private keys that a server will+ -- use as part of authentication to clients. Actual credentials+ -- that are used are selected dynamically from this list based on+ -- client capabilities. Additional credentials returned by+ -- 'onServerNameIndication' are also considered. -- -- When credential list is left empty (the default value), no key -- exchange can take place.@@ -387,35 +431,40 @@ -- Default: 'mempty' , sharedSessionManager :: SessionManager -- ^ Callbacks used by clients and servers in order to resume TLS- -- sessions. The default implementation never resumes sessions. Package- -- <https://hackage.haskell.org/package/tls-session-manager tls-session-manager>- -- provides an in-memory implementation.+ -- sessions. The default implementation never resumes sessions.+ -- Package+ -- <https://hackage.haskell.org/package/tls-session-manager+ -- tls-session-manager> provides an in-memory implementation. -- -- Default: 'noSessionManager' , sharedCAStore :: CertificateStore- -- ^ A collection of trust anchors to be used by a client as- -- part of validation of server certificates. This is set as- -- first argument to function 'onServerCertificate'. Package- -- <https://hackage.haskell.org/package/crypton-x509-system crypton-x509-system>- -- gives access to a default certificate store configured in the- -- system.+ -- ^ A collection of trust anchors to be used by a client as part+ -- of validation of server certificates. This is set as first+ -- argument to function 'onServerCertificate'. Package+ -- <https://hackage.haskell.org/package/crypton-x509-system+ -- crypton-x509-system> gives access to a default certificate+ -- store configured in the system. -- -- Default: 'mempty' , sharedValidationCache :: ValidationCache -- ^ Callbacks that may be used by a client to cache certificate -- validation results (positive or negative) and avoid expensive- -- signature check. The default implementation does not have- -- any caching.+ -- signature check. The default implementation does not have any+ -- caching. -- -- See the default value of 'ValidationCache'. , sharedHelloExtensions :: [ExtensionRaw] -- ^ Additional extensions to be sent during the Hello sequence. --- -- For a client this is always included in message ClientHello. For a- -- server, this is sent in messages ServerHello or EncryptedExtensions- -- based on the TLS version.+ -- For a client this is always included in message ClientHello.+ -- For a server, this is sent in messages ServerHello or+ -- EncryptedExtensions based on the TLS version. -- -- Default: @[]@+ , sharedECHConfigList :: ECHConfigList+ -- ^ ECH configuration.+ --+ -- @since 2.1.9 , sharedLimit :: Limit -- ^ Limitation parameters. --@@ -435,6 +484,7 @@ , sharedCAStore = mempty , sharedValidationCache = def , sharedHelloExtensions = []+ , sharedECHConfigList = [] , sharedLimit = defaultLimit } @@ -485,82 +535,84 @@ { onCertificateRequest :: OnCertificateRequest -- ^ This action is called when the a certificate request is -- received from the server. The callback argument is the- -- information from the request. The server, at its- -- discretion, may be willing to continue the handshake- -- without a client certificate. Therefore, the callback is- -- free to return 'Nothing' to indicate that no client- -- certificate should be sent, despite the server's request.- -- In some cases it may be appropriate to get user consent- -- before sending the certificate; the content of the user's- -- certificate may be sensitive and intended only for- -- specific servers.+ -- information from the request. The server, at its discretion,+ -- may be willing to continue the handshake without a client+ -- certificate. Therefore, the callback is free to return+ -- 'Nothing' to indicate that no client certificate should be+ -- sent, despite the server's request. In some cases it may be+ -- appropriate to get user consent before sending the certificate;+ -- the content of the user's certificate may be sensitive and+ -- intended only for specific servers. --- -- The action should select a certificate chain of one of- -- the given certificate types and one of the certificates- -- in the chain should (if possible) be signed by one of the- -- given distinguished names. Some servers, that don't have- -- a narrow set of preferred issuer CAs, will send an empty- -- 'DistinguishedName' list, rather than send all the names- -- from their trusted CA bundle. If the client does not- -- have a certificate chaining to a matching CA, it may- -- choose a default certificate instead.+ -- The action should select a certificate chain of one of the+ -- given certificate types and one of the certificates in the+ -- chain should (if possible) be signed by one of the given+ -- distinguished names. Some servers, that don't have a narrow+ -- set of preferred issuer CAs, will send an empty+ -- 'DistinguishedName' list, rather than send all the names from+ -- their trusted CA bundle. If the client does not have a+ -- certificate chaining to a matching CA, it may choose a default+ -- certificate instead. -- -- Each certificate except the last should be signed by the- -- following one. The returned private key must be for the- -- first certificates in the chain. This key will be used- -- to signing the certificate verify message.+ -- following one. The returned private key must be for the first+ -- certificates in the chain. This key will be used to signing+ -- the certificate verify message. -- -- The public key in the first certificate, and the matching- -- returned private key must be compatible with one of the- -- list of 'HashAndSignatureAlgorithm' value when provided.- -- TLS 1.3 changes the meaning of the list elements, adding- -- explicit code points for each supported pair of hash and- -- signature (public key) algorithms, rather than combining- -- separate codes for the hash and key. For details see+ -- returned private key must be compatible with one of the list of+ -- 'HashAndSignatureAlgorithm' value when provided. TLS 1.3+ -- changes the meaning of the list elements, adding explicit code+ -- points for each supported pair of hash and signature (public+ -- key) algorithms, rather than combining separate codes for the+ -- hash and key. For details see -- <https://tools.ietf.org/html/rfc8446#section-4.2.3 RFC 8446> -- section 4.2.3. When no compatible certificate chain is- -- available, return 'Nothing' if it is OK to continue- -- without a client certificate. Returning a non-matching- -- certificate should result in a handshake failure.+ -- available, return 'Nothing' if it is OK to continue without a+ -- client certificate. Returning a non-matching certificate+ -- should result in a handshake failure. --- -- While the TLS version is not provided to the callback,- -- the content of the @signature_algorithms@ list provides- -- a strong hint, since TLS 1.3 servers will generally list- -- RSA pairs with a hash component of 'Intrinsic' (@0x08@).+ -- While the TLS version is not provided to the callback, the+ -- content of the @signature_algorithms@ list provides a strong+ -- hint, since TLS 1.3 servers will generally list RSA pairs with+ -- a hash component of 'Intrinsic' (@0x08@). --- -- Note that is is the responsibility of this action to- -- select a certificate matching one of the requested- -- certificate types (public key algorithms). Returning- -- a non-matching one will lead to handshake failure later.+ -- Note that is is the responsibility of this action to select a+ -- certificate matching one of the requested certificate types+ -- (public key algorithms). Returning a non-matching one will+ -- lead to handshake failure later. -- -- Default: returns 'Nothing' anyway. , onServerCertificate :: OnServerCertificate- -- ^ Used by the client to validate the server certificate. The default- -- implementation calls 'validateDefault' which validates according to the- -- default hooks and checks provided by "Data.X509.Validation". This can- -- be replaced with a custom validation function using different settings.+ -- ^ Used by the client to validate the server certificate. The+ -- default implementation calls 'validateDefault' which validates+ -- according to the default hooks and checks provided by+ -- "Data.X509.Validation". This can be replaced with a custom+ -- validation function using different settings. --- -- The function is not expected to verify the key-usage extension of the- -- end-entity certificate, as this depends on the dynamically-selected- -- cipher and this part should not be cached. Key-usage verification- -- is performed by the library internally.+ -- The function is not expected to verify the key-usage extension+ -- of the end-entity certificate, as this depends on the+ -- dynamically-selected cipher and this part should not be cached.+ -- Key-usage verification is performed by the library internally. -- -- Default: 'validateDefault'- , onSuggestALPN :: IO (Maybe [B.ByteString])+ , onSuggestALPN :: IO (Maybe [ByteString]) -- ^ This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. -- -- Default: returns 'Nothing' , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage- -- ^ This action is called to validate DHE parameters when the server- -- selected a finite-field group not part of the "Supported Groups- -- Registry" or not part of 'supportedGroups' list.+ -- ^ This action is called to validate DHE parameters when the+ -- server selected a finite-field group not part of the+ -- "Supported Groups Registry" or not part of 'supportedGroups'+ -- list. --- -- With TLS 1.3 custom groups have been removed from the protocol, so- -- this callback is only used when the version negotiated is 1.2 or- -- below.+ -- With TLS 1.3 custom groups have been removed from the+ -- protocol, so this callback is only used when the version+ -- negotiated is 1.2 or below. --- -- The default behavior with (dh_p, dh_g, dh_size) and pub as follows:+ -- The default behavior with (dh_p, dh_g, dh_size) and pub as+ -- follows: -- -- (1) rejecting if dh_p is even -- (2) rejecting unless 1 < dh_g && dh_g < dh_p - 1@@ -590,13 +642,13 @@ -- | A set of callbacks run by the server for various corners of the TLS establishment data ServerHooks = ServerHooks { onClientCertificate :: CertificateChain -> IO CertificateUsage- -- ^ This action is called when a client certificate chain- -- is received from the client. When it returns a+ -- ^ This action is called when a client certificate chain is+ -- received from the client. When it returns a -- CertificateUsageReject value, the handshake is aborted. --- -- The function is not expected to verify the key-usage- -- extension of the certificate. This verification is- -- performed by the library internally.+ -- The function is not expected to verify the key-usage extension+ -- of the certificate. This verification is performed by the+ -- library internally. -- -- Default: returns the followings: --@@ -604,44 +656,44 @@ -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") -- @ , onUnverifiedClientCert :: IO Bool- -- ^ This action is called when the client certificate- -- cannot be verified. Return 'True' to accept the certificate- -- anyway, or 'False' to fail verification.+ -- ^ This action is called when the client certificate cannot be+ -- verified. Return 'True' to accept the certificate anyway, or+ -- 'False' to fail verification. -- -- Default: returns 'False' , onCipherChoosing :: Version -> [Cipher] -> Cipher- -- ^ Allow the server to choose the cipher relative to the- -- the client version and the client list of ciphers.+ -- ^ Allow the server to choose the cipher relative to the the+ -- client version and the client list of ciphers. --- -- This could be useful with old clients and as a workaround- -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1)+ -- This could be useful with old clients and as a workaround to+ -- the BEAST (where RC4 is sometimes prefered with TLS < 1.1) -- -- The client cipher list cannot be empty. -- -- Default: taking the head of ciphers. , onServerNameIndication :: Maybe HostName -> IO Credentials- -- ^ Allow the server to indicate additional credentials- -- to be used depending on the host name indicated by the- -- client.+ -- ^ Allow the server to indicate additional credentials to be+ -- used depending on the host name indicated by the client. --- -- This is most useful for transparent proxies where- -- credentials must be generated on the fly according to- -- the host the client is trying to connect to.+ -- This is most useful for transparent proxies where credentials+ -- must be generated on the fly according to the host the client+ -- is trying to connect to. --- -- Returned credentials may be ignored if a client does not support- -- the signature algorithms used in the certificate chain.+ -- Returned credentials may be ignored if a client does not+ -- support the signature algorithms used in the certificate chain. -- -- Default: returns 'mempty' , onNewHandshake :: Measurement -> IO Bool- -- ^ At each new handshake, we call this hook to see if we allow handshake to happens.+ -- ^ At each new handshake, we call this hook to see if we allow+ -- handshake to happens. -- -- Default: returns 'True'- , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)+ , onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString) -- ^ Allow the server to choose an application layer protocol- -- suggested from the client through the ALPN- -- (Application Layer Protocol Negotiation) extensions.- -- If the server supports no protocols that the client advertises- -- an empty 'ByteString' should be returned.+ -- suggested from the client through the ALPN (Application Layer+ -- Protocol Negotiation) extensions. If the server supports no+ -- protocols that the client advertises an empty 'ByteString'+ -- should be returned. -- -- Default: 'Nothing' , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]@@ -687,6 +739,7 @@ , infoTLS12Resumption :: Bool , infoTLS13HandshakeMode :: Maybe HandshakeMode13 , infoIsEarlyDataAccepted :: Bool+ , infoIsECHAccepted :: Bool } deriving (Show, Eq) @@ -702,8 +755,8 @@ -- In the case of 'Just': A client sends the "record_size_limit" -- extension with this value to the server. A server sends back -- this extension with its own value if a client sends the- -- extension. When negotiated, both my limit and peer's limit- -- are enabled for protected communication.+ -- extension. When negotiated, both my limit and peer's limit are+ -- enabled for protected communication. -- -- Default: Nothing , limitHandshakeFragment :: Int
Network/TLS/PostHandshake.hs view
@@ -3,28 +3,29 @@ requestCertificateServer, postHandshakeAuthWith, postHandshakeAuthClientWith,- postHandshakeAuthServerWith, ) where import Network.TLS.Context.Internal-import Network.TLS.IO-import Network.TLS.Struct13- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.IO+import Network.TLS.Struct13 --- | Post-handshake certificate request with TLS 1.3. Returns 'True' if the--- request was possible, i.e. if TLS 1.3 is used and the remote client supports--- post-handshake authentication.+----------------------------------------------------------------++-- | Post-handshake certificate request with TLS 1.3. Returns 'False'+-- if the request was impossible, i.e. the remote client supports+-- post-handshake authentication or the connection is established in+-- TLS 1.2. Returns 'True' if the client authentication succeeds. An+-- exception is thrown if the authentication fails. Server only. requestCertificate :: Context -> IO Bool requestCertificate ctx =- withWriteLock ctx $- checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx+ checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx --- Handle a post-handshake authentication flight with TLS 1.3. This is called--- automatically by 'recvData', in a context where the read lock is already--- taken.+-- | Handle a post-handshake authentication flight with TLS 1.3. This+-- is called automatically by 'recvData', in a context where the read+-- lock is already taken. Client only. postHandshakeAuthWith :: Context -> Handshake13 -> IO () postHandshakeAuthWith ctx hs = withWriteLock ctx $
Network/TLS/QUIC.hs view
@@ -68,6 +68,8 @@ defaultSupported, ) where +import Data.Default (def)+ import Network.TLS.Backend import Network.TLS.Context import Network.TLS.Context.Internal@@ -87,8 +89,6 @@ import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Types--import Data.Default (def) nullBackend :: Backend nullBackend =
Network/TLS/Record/Decrypt.hs view
@@ -131,7 +131,7 @@ (iv, econtent') <- get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk) let (content', iv') = decryptF iv econtent'- modify $ \txs -> txs{stCryptState = cst{cstIV = iv'}}+ modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}} let paddinglength = fromIntegral (B.last content') + 1 let contentlen = B.length content' - paddinglength - macSize@@ -151,7 +151,7 @@ {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2i content' (contentlen, macSize)- modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}+ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}} getCipherData record CipherData@@ -188,7 +188,7 @@ throwError $ Error_Protocol "bad record mac on AEAD" BadRecordMac - modify incrRecordState+ modify' incrRecordState return content decryptOf BulkStateUninitialized = throwError $ Error_Protocol "decrypt state uninitialized" InternalError
Network/TLS/Record/Encrypt.hs view
@@ -13,9 +13,9 @@ import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..))- import qualified Data.ByteArray as B (convert, xor) import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Imports import Network.TLS.Packet@@ -91,7 +91,7 @@ encryptStream (BulkStream encryptF) content = do cst <- getCryptState let (!e, !newBulkStream) = encryptF content- modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}+ modify' $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}} return e encryptAead@@ -123,7 +123,7 @@ econtent | nonceExpLen == 0 = e `B.append` B.convert authtag | otherwise = B.concat [encodedSeq, e, B.convert authtag]- modify incrRecordState+ modify' incrRecordState return econtent getCryptState :: RecordM CryptState
Network/TLS/Record/Send.hs view
@@ -5,6 +5,10 @@ sendBytes, ) where +import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Hooks@@ -13,10 +17,6 @@ import Network.TLS.Record import Network.TLS.Struct -import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B- encodeRecordM :: Record Plaintext -> RecordM ByteString encodeRecordM record = do erecord <- encryptRecord record@@ -42,7 +42,7 @@ if sz > 0 then do newIV <- getStateRNG ctx sz- runTxRecordState ctx (modify (setRecordIV newIV) >> f)+ runTxRecordState ctx (modify' (setRecordIV newIV) >> f) else runTxRecordState ctx f ----------------------------------------------------------------
Network/TLS/Record/Types.hs view
@@ -32,6 +32,7 @@ ) where import qualified Data.ByteString as B+ import Network.TLS.Imports import Network.TLS.Record.State import Network.TLS.Struct
Network/TLS/State.hs view
@@ -72,8 +72,8 @@ import Control.Monad.State.Strict import Crypto.Random-import qualified Data.ByteString as B import Data.X509 (CertificateChain)+ import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.Imports@@ -92,10 +92,10 @@ , -- RFC 5929, Channel Bindings for TLS, "tls-server-end-point" stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301- , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString))- , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol+ , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol+ , stHandshakeRecordCont12 :: Maybe (GetContinuation (HandshakeType, ByteString)) , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString))- , stClientALPNSuggest :: Maybe [B.ByteString]+ , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain@@ -135,9 +135,9 @@ , stServerVerifyData = Nothing , stServerCertificateChain = Nothing , stExtensionALPN = False- , stHandshakeRecordCont = Nothing- , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing+ , stHandshakeRecordCont12 = Nothing+ , stHandshakeRecordCont13 = Nothing , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing@@ -160,15 +160,15 @@ setVerifyDataForSend bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stClientVerifyData = Just bs})- ServerRole -> modify (\st -> st{stServerVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stClientVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stServerVerifyData = Just bs}) setVerifyDataForRecv :: VerifyData -> TLSSt () setVerifyDataForRecv bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stServerVerifyData = Just bs})- ServerRole -> modify (\st -> st{stClientVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stServerVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stClientVerifyData = Just bs}) finishedHandshakeTypeMaterial :: HandshakeType -> Bool finishedHandshakeTypeMaterial HandshakeType_ClientHello = True@@ -204,22 +204,22 @@ certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake setSession :: Session -> TLSSt ()-setSession session = modify (\st -> st{stSession = session})+setSession session = modify' (\st -> st{stSession = session}) getSession :: TLSSt Session getSession = gets stSession setTLS12SessionResuming :: Bool -> TLSSt ()-setTLS12SessionResuming b = modify (\st -> st{stTLS12SessionResuming = b})+setTLS12SessionResuming b = modify' (\st -> st{stTLS12SessionResuming = b}) getTLS12SessionResuming :: TLSSt Bool getTLS12SessionResuming = gets stTLS12SessionResuming setVersion :: Version -> TLSSt ()-setVersion ver = modify (\st -> st{stVersion = Just ver})+setVersion ver = modify' (\st -> st{stVersion = Just ver}) setVersionIfUnset :: Version -> TLSSt ()-setVersionIfUnset ver = modify maybeSet+setVersionIfUnset ver = modify' maybeSet where maybeSet st = case stVersion st of Nothing -> st{stVersion = Just ver}@@ -234,52 +234,52 @@ getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt ()-setSecureRenegotiation b = modify (\st -> st{stSecureRenegotiation = b})+setSecureRenegotiation b = modify' (\st -> st{stSecureRenegotiation = b}) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionALPN :: Bool -> TLSSt ()-setExtensionALPN b = modify (\st -> st{stExtensionALPN = b})+setExtensionALPN b = modify' (\st -> st{stExtensionALPN = b}) getExtensionALPN :: TLSSt Bool getExtensionALPN = gets stExtensionALPN -setNegotiatedProtocol :: B.ByteString -> TLSSt ()-setNegotiatedProtocol s = modify (\st -> st{stNegotiatedProtocol = Just s})+setNegotiatedProtocol :: ByteString -> TLSSt ()+setNegotiatedProtocol s = modify' (\st -> st{stNegotiatedProtocol = Just s}) -getNegotiatedProtocol :: TLSSt (Maybe B.ByteString)+getNegotiatedProtocol :: TLSSt (Maybe ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol -setClientALPNSuggest :: [B.ByteString] -> TLSSt ()-setClientALPNSuggest ps = modify (\st -> st{stClientALPNSuggest = Just ps})+setClientALPNSuggest :: [ByteString] -> TLSSt ()+setClientALPNSuggest ps = modify' (\st -> st{stClientALPNSuggest = Just ps}) -getClientALPNSuggest :: TLSSt (Maybe [B.ByteString])+getClientALPNSuggest :: TLSSt (Maybe [ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt ()-setClientEcPointFormatSuggest epf = modify (\st -> st{stClientEcPointFormatSuggest = Just epf})+setClientEcPointFormatSuggest epf = modify' (\st -> st{stClientEcPointFormatSuggest = Just epf}) getClientEcPointFormatSuggest :: TLSSt (Maybe [EcPointFormat]) getClientEcPointFormatSuggest = gets stClientEcPointFormatSuggest setClientCertificateChain :: CertificateChain -> TLSSt ()-setClientCertificateChain s = modify (\st -> st{stClientCertificateChain = Just s})+setClientCertificateChain s = modify' (\st -> st{stClientCertificateChain = Just s}) getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain setServerCertificateChain :: CertificateChain -> TLSSt ()-setServerCertificateChain s = modify (\st -> st{stServerCertificateChain = Just s})+setServerCertificateChain s = modify' (\st -> st{stServerCertificateChain = Just s}) getServerCertificateChain :: TLSSt (Maybe CertificateChain) getServerCertificateChain = gets stServerCertificateChain setClientSNI :: HostName -> TLSSt ()-setClientSNI hn = modify (\st -> st{stClientSNI = Just hn})+setClientSNI hn = modify' (\st -> st{stClientSNI = Just hn}) clearClientSNI :: TLSSt ()-clearClientSNI = modify (\st -> st{stClientSNI = Nothing})+clearClientSNI = modify' (\st -> st{stClientSNI = Nothing}) getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI@@ -330,43 +330,43 @@ return a setTLS12SessionTicket :: Ticket -> TLSSt ()-setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t})+setTLS12SessionTicket t = modify' (\st -> st{stTLS12SessionTicket = Just t}) getTLS12SessionTicket :: TLSSt (Maybe Ticket) getTLS12SessionTicket = gets stTLS12SessionTicket setTLS13ExporterSecret :: ByteString -> TLSSt ()-setTLS13ExporterSecret key = modify (\st -> st{stTLS13ExporterSecret = Just key})+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})+setTLS13KeyShare mks = modify' (\st -> st{stTLS13KeyShare = mks}) getTLS13KeyShare :: TLSSt (Maybe KeyShare) getTLS13KeyShare = gets stTLS13KeyShare setTLS13PreSharedKey :: Maybe PreSharedKey -> TLSSt ()-setTLS13PreSharedKey mpsk = modify (\st -> st{stTLS13PreSharedKey = mpsk})+setTLS13PreSharedKey mpsk = modify' (\st -> st{stTLS13PreSharedKey = mpsk}) getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey) getTLS13PreSharedKey = gets stTLS13PreSharedKey setTLS13HRR :: Bool -> TLSSt ()-setTLS13HRR b = modify (\st -> st{stTLS13HRR = b})+setTLS13HRR b = modify' (\st -> st{stTLS13HRR = b}) getTLS13HRR :: TLSSt Bool getTLS13HRR = gets stTLS13HRR setTLS13Cookie :: Maybe Cookie -> TLSSt ()-setTLS13Cookie mcookie = modify (\st -> st{stTLS13Cookie = mcookie})+setTLS13Cookie mcookie = modify' (\st -> st{stTLS13Cookie = mcookie}) getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie setTLS13ClientSupportsPHA :: Bool -> TLSSt ()-setTLS13ClientSupportsPHA b = modify (\st -> st{stTLS13ClientSupportsPHA = b})+setTLS13ClientSupportsPHA b = modify' (\st -> st{stTLS13ClientSupportsPHA = b}) getTLS13ClientSupportsPHA :: TLSSt Bool getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA
Network/TLS/Struct.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} -- | The Struct module contains all definitions and values of the TLS@@ -105,10 +106,9 @@ HandshakeType_KeyUpdate, HandshakeType_CompressedCertificate ),- TLSCertificateChain (..),- emptyTLSCertificateChain,+ CertificateChain_ (..),+ emptyCertificateChain_, Handshake (..),- CH (..), packetType, typeOfHandshake, module Network.TLS.HashAndSignature,@@ -117,6 +117,8 @@ showCertificateChain, isHelloRetryRequest, hrrRandom,+ ClientHello (..),+ ServerHello (..), ) where import Data.X509 (@@ -315,18 +317,21 @@ pattern HandshakeType_CompressedCertificate = HandshakeType 25 instance Show HandshakeType where- show HandshakeType_HelloRequest = "HandshakeType_HelloRequest"- show HandshakeType_ClientHello = "HandshakeType_ClientHello"- show HandshakeType_ServerHello = "HandshakeType_ServerHello"- show HandshakeType_Certificate = "HandshakeType_Certificate"- show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg"- show HandshakeType_CertRequest = "HandshakeType_CertRequest"- show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone"- show HandshakeType_CertVerify = "HandshakeType_CertVerify"- show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg"- show HandshakeType_Finished = "HandshakeType_Finished"- show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket"- show HandshakeType_CompressedCertificate = "HandshakeType_CompressedCertificate"+ show HandshakeType_HelloRequest = "HelloRequest"+ show HandshakeType_ClientHello = "ClientHello"+ show HandshakeType_ServerHello = "ServerHello"+ show HandshakeType_NewSessionTicket = "NewSessionTicket"+ show HandshakeType_EndOfEarlyData = "EndOfEarlyData"+ show HandshakeType_EncryptedExtensions = "EncryptedExtensions"+ show HandshakeType_Certificate = "Certificate"+ show HandshakeType_ServerKeyXchg = "ServerKeyXchg"+ show HandshakeType_CertRequest = "CertRequest"+ show HandshakeType_ServerHelloDone = "ServerHelloDone"+ show HandshakeType_CertVerify = "CertVerify"+ show HandshakeType_ClientKeyXchg = "ClientKeyXchg"+ show HandshakeType_Finished = "Finished"+ show HandshakeType_KeyUpdate = "KeyUpdate"+ show HandshakeType_CompressedCertificate = "CompressedCertificate" show (HandshakeType x) = "HandshakeType " ++ show x {- FOURMOLU_ENABLE -} @@ -417,19 +422,12 @@ ---------------------------------------------------------------- -data CH = CH- { chSession :: Session- , chCiphers :: [CipherId]- , chExtensions :: [ExtensionRaw]- }- deriving (Show, Eq)--newtype TLSCertificateChain = TLSCertificateChain CertificateChain deriving (Eq)-instance Show TLSCertificateChain where- show (TLSCertificateChain cc) = showCertificateChain cc+newtype CertificateChain_ = CertificateChain_ CertificateChain deriving (Eq)+instance Show CertificateChain_ where+ show (CertificateChain_ cc) = showCertificateChain cc -emptyTLSCertificateChain :: TLSCertificateChain-emptyTLSCertificateChain = TLSCertificateChain (CertificateChain [])+emptyCertificateChain_ :: CertificateChain_+emptyCertificateChain_ = CertificateChain_ (CertificateChain []) showCertificateChain :: CertificateChain -> String showCertificateChain (CertificateChain xs) = show $ map getName xs@@ -442,20 +440,30 @@ . signedObject . getSigned +data ClientHello = CH+ { chVersion :: Version+ , chRandom :: ClientRandom+ , chSession :: Session+ , chCiphers :: [CipherId]+ , chComps :: [CompressionID]+ , chExtensions :: [ExtensionRaw]+ }+ deriving (Eq, Show)++data ServerHello = SH+ { shVersion :: Version+ , shRandom :: ServerRandom+ , shSession :: Session+ , shCipher :: CipherId+ , shComp :: CompressionID+ , shExtensions :: [ExtensionRaw]+ }+ deriving (Eq, Show)+ data Handshake- = ClientHello- Version- ClientRandom- [CompressionID]- CH- | ServerHello- Version- ServerRandom- Session- CipherId- CompressionID- [ExtensionRaw]- | Certificate TLSCertificateChain+ = ClientHello ClientHello+ | ServerHello ServerHello+ | Certificate CertificateChain_ | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData
Network/TLS/Struct13.hs view
@@ -6,6 +6,8 @@ KeyUpdate (..), CertReqContext, isKeyUpdate13,+ TicketNonce (..),+ SessionIDorTicket_ (..), ) where import Network.TLS.Imports@@ -24,20 +26,28 @@ | UpdateRequested deriving (Show, Eq) -type TicketNonce = ByteString+newtype TicketNonce = TicketNonce ByteString deriving (Eq) +instance Show TicketNonce where+ show (TicketNonce bs) = showBytesHex bs++newtype SessionIDorTicket_ = SessionIDorTicket_ ByteString deriving (Eq)++instance Show SessionIDorTicket_ where+ show (SessionIDorTicket_ bs) = showBytesHex bs+ -- fixme: convert Word32 to proper data type data Handshake13- = ServerHello13 ServerRandom Session CipherId [ExtensionRaw]- | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw]+ = ServerHello13 ServerHello+ | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket_ [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw]- | Certificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]]+ | Certificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] | CertRequest13 CertReqContext [ExtensionRaw] | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate- | CompressedCertificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]]+ | CompressedCertificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] deriving (Show, Eq) -- | Certificate request context for TLS 1.3.
Network/TLS/Types.hs view
@@ -11,6 +11,7 @@ bigNumToInteger, bigNumFromInteger, defaultRecordSizeLimit,+ TranscriptHash (..), ) where import Network.Socket (HostName)@@ -56,3 +57,10 @@ -- 2^14 + 1 for TLS 1.3 defaultRecordSizeLimit :: Int defaultRecordSizeLimit = 16384++----------------------------------------------------------------++newtype TranscriptHash = TranscriptHash ByteString++instance Show TranscriptHash where+ show (TranscriptHash bs) = showBytesHex bs
Network/TLS/Types/Secret.hs view
@@ -13,17 +13,30 @@ data ResumptionSecret -newtype BaseSecret a = BaseSecret ByteString deriving (Show)-newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show)+newtype BaseSecret a = BaseSecret ByteString +instance Show (BaseSecret a) where+ show (BaseSecret bs) = showBytesHex bs++newtype AnyTrafficSecret a = AnyTrafficSecret ByteString++instance Show (AnyTrafficSecret a) where+ show (AnyTrafficSecret bs) = showBytesHex bs+ -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show)+newtype ClientTrafficSecret a = ClientTrafficSecret ByteString +instance Show (ClientTrafficSecret a) where+ show (ClientTrafficSecret bs) = showBytesHex bs+ -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show)+newtype ServerTrafficSecret a = ServerTrafficSecret ByteString +instance Show (ServerTrafficSecret a) where+ show (ServerTrafficSecret bs) = showBytesHex bs+ data SecretTriple a = SecretTriple { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a@@ -35,9 +48,13 @@ { pairBase :: BaseSecret a , pairClient :: ClientTrafficSecret a }+ deriving (Show) -- | Hold both client and server traffic secrets at the same step. type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) -- Main secret for TLS 1.2 or earlier.-newtype MainSecret = MainSecret ByteString deriving (Show)+newtype MainSecret = MainSecret ByteString++instance Show MainSecret where+ show (MainSecret bs) = showBytesHex bs
Network/TLS/Util.hs view
@@ -16,13 +16,13 @@ restoreMVar, ) where -import qualified Data.ByteString as B-import Network.TLS.Imports- import Control.Concurrent.MVar import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E+import qualified Data.ByteString as B +import Network.TLS.Imports+ sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len | B.length b < offset + len = Nothing@@ -87,12 +87,12 @@ mapChunks_ :: Monad m => Maybe Int- -> (B.ByteString -> m a)- -> B.ByteString+ -> (ByteString -> m a)+ -> ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len -getChunks :: Maybe Int -> B.ByteString -> [B.ByteString]+getChunks :: Maybe Int -> ByteString -> [ByteString] getChunks Nothing = (: []) getChunks (Just len) = go where
Network/TLS/Util/ASN1.hs view
@@ -7,6 +7,7 @@ import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.Types (ASN1Object, fromASN1, toASN1)+ import Network.TLS.Imports -- | Attempt to decode a bytestring representing
test/Arbitrary.hs view
@@ -72,18 +72,24 @@ arbitrary = oneof [ arbitrary >>= \ver -> do- ClientHello ver- <$> arbitrary- <*> arbitraryCompressionIDs- <*> (CH <$> arbitrary <*> arbitraryCiphersIds <*> arbitraryHelloExtensions ver)+ ClientHello+ <$> ( CH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitraryCiphersIds+ <*> arbitraryCompressionIDs+ <*> arbitraryHelloExtensions ver+ ) , arbitrary >>= \ver ->- ServerHello ver- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver- , Certificate . TLSCertificateChain . CertificateChain+ ServerHello+ <$> ( SH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitraryHelloExtensions ver+ )+ , Certificate . CertificateChain_ . CertificateChain <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone@@ -98,15 +104,18 @@ oneof [ arbitrary >>= \ver -> ServerHello13- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver+ <$> ( SH TLS12+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> pure 0+ <*> arbitraryHelloExtensions ver+ ) , NewSessionTicket13 <$> arbitrary <*> arbitrary- <*> genByteString 32 -- nonce- <*> genByteString 32 -- session ID+ <*> (TicketNonce <$> genByteString 32) -- nonce+ <*> (SessionIDorTicket_ <$> genByteString 32) -- session ID <*> arbitrary , pure EndOfEarlyData13 , EncryptedExtensions13 <$> arbitrary@@ -116,7 +125,7 @@ , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 <$> arbitraryCertReqContext- <*> return (TLSCertificateChain (CertificateChain certs))+ <*> return (CertificateChain_ (CertificateChain certs)) <*> replicateM (length certs) arbitrary , CertVerify13 <$> ( DigitallySigned . unsafeHead
+ test/ECHSpec.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module ECHSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import Data.Maybe+import Network.TLS+import Network.TLS.ECH.Config+import Network.TLS.Extra.Cipher+import Network.TLS.Internal+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Arbitrary+import Run+import Session++spec :: Spec+spec = do+ describe "ECH" $ do+ prop "can handshake with TLS 1.3 Full" handshake13_full+ prop "can handshake with TLS 1.3 HRR" handshake13_hrr+ prop "can handshake with TLS 1.3 PSK" handshake13_psk+ prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket+ prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback+ prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt+ prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback+ prop "can handshake with TLS 1.3 EC groups" handshake13_ec+ prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+ describe "ECH greasing" $ do+ prop "sends greasing ECH" handshake13_greasing+ prop "sends greasing ECH HRR" handshake13_greasing_hrr++--------------------------------------------------------------++newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP13 where+ arbitrary = CSP13 <$> arbitraryPairParams13++--------------------------------------------------------------++handshake13_full :: CSP13 -> IO ()+handshake13_full (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_hrr :: CSP13 -> IO ()+handshake13_hrr (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params HelloRetryRequest++handshake13_psk :: CSP13 -> IO ()+handshake13_psk (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH params2 PreSharedKey++handshake13_psk_ticket :: CSP13 -> IO ()+handshake13_psk_ticket (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers0 = twoSessionManagers sessionRefs+ sessionManagers = (fst sessionManagers0, oneSessionTicket)++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH params2 PreSharedKey++handshake13_psk_fallback :: CSP13 -> IO ()+handshake13_psk_fallback (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers =+ [ cipher13_AES_128_GCM_SHA256+ , cipher13_AES_128_CCM_SHA256+ ]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- resumption fails because GCM cipher is not supported anymore, full+ -- handshake is not possible because X25519 has been removed, so we are+ -- back with P256 after hello retry+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params+ srv2' = srv2{serverSupported = svrSupported'}+ svrSupported' =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_CCM_SHA256]+ , supportedGroups = [P256]+ }++ runTLSSimple13ECH (cli2, srv2') HelloRetryRequest++handshake13_0rtt :: CSP13 -> IO ()+handshake13_0rtt (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ cliHooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just ["h2"]+ }+ svrHooks =+ defaultServerHooks+ { onALPNClientSuggest = Just (return . unsafeHead)+ }+ params0 =+ setParams+ ( cli+ { clientSupported = cliSupported+ , clientHooks = cliHooks+ }+ , srv+ { serverSupported = svrSupported+ , serverHooks = svrHooks+ , serverEarlyDataSize = 2048+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest+ runTLS0rtt params sessionRefs+ runTLS0rtt params sessionRefs+ where+ runTLS0rtt params sessionRefs = do+ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ clearClientSessionRef sessionRefs+ earlyData <- B.pack <$> generate (someWords8 256)+ let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ params2 = (pc{clientUseEarlyData = True}, ps)++ runTLS0RTTech params2 RTT0 earlyData++handshake13_0rtt_fallback :: CSP13 -> IO ()+handshake13_0rtt_fallback (CSP13 (cli, srv)) = do+ group0 <- generate $ elements [P256, X25519]+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group0]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv+ { serverSupported = svrSupported+ , serverEarlyDataSize = 1024+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params0 = setPairParamsSessionManagers sessionManagers params++ let mode = if group0 == P256 then FullHandshake else HelloRetryRequest+ runTLSSimple13ECH params0 mode++ -- and resume+ mSessionParams <- readClientSessionRef sessionRefs+ case mSessionParams of+ Nothing -> expectationFailure "session params: Just is expected"+ Just sessionParams -> do+ earlyData <- B.pack <$> generate (someWords8 256)+ group1 <- generate $ elements [P256, X25519]+ let (pc, ps) = setPairParamsSessionResuming sessionParams params0+ svrSupported1 =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group1]+ }+ params1 =+ ( pc{clientUseEarlyData = True}+ , ps+ { serverEarlyDataSize = 0+ , serverSupported = svrSupported1+ }+ )+ -- C: [P256, X25519]+ -- S: [group0]+ -- C: [P256, X25519]+ -- S: [group1]+ if group0 == group1+ -- 0-RTT is not allowed, so fallback to PreSharedKey+ then runTLS0RTTech params1 PreSharedKey earlyData+ -- HRR but not allowed for 0-RTT+ else runTLSFailure params1 (tlsClient earlyData) tlsServer+ where+ tlsClient earlyData ctx = do+ handshake ctx+ sendData ctx $ L.fromStrict earlyData+ _ <- recvData ctx+ bye ctx+ tlsServer ctx = do+ handshake ctx+ _ <- recvData ctx+ bye ctx++handshake13_ec :: CSP13 -> IO ()+handshake13_ec (CSP13 (cli, srv)) = do+ EC cgrps <- generate arbitrary+ EC sgrps <- generate arbitrary+ let cliSupported = (clientSupported cli){supportedGroups = cgrps}+ svrSupported = (serverSupported srv){supportedGroups = sgrps}+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_ffdhe :: CSP13 -> IO ()+handshake13_ffdhe (CSP13 (cli, srv)) = do+ FFDHE cgrps <- generate arbitrary+ FFDHE sgrps <- generate arbitrary+ let cliSupported = (clientSupported cli){supportedGroups = cgrps}+ svrSupported = (serverSupported srv){supportedGroups = sgrps}+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_greasing :: CSP13 -> IO ()+handshake13_greasing (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params =+ ( cli+ { clientSupported = cliSupported+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True]++handshake13_greasing_hrr :: CSP13 -> IO ()+handshake13_greasing_hrr (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params =+ ( cli+ { clientSupported = cliSupported+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True, True]++expectJust :: String -> Maybe a -> Expectation+expectJust tag mx = case mx of+ Nothing -> expectationFailure tag+ Just _ -> return ()++setParams :: (ClientParams, ServerParams) -> (ClientParams, ServerParams)+setParams (cli, srv) = (cli', srv')+ where+ cli' =+ cli+ { clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ srv' =+ srv+ { serverECHKey = echKey+ , serverShared = (serverShared srv){sharedECHConfigList = echConfList}+ }++echKey :: [(ConfigId, ByteString)]+echKey = [(0, B64.decodeLenient "GAl/YqzDDnssODe5t+2xlQsbSv26kNlfJ0D+nZbK62I=")]++echConfList :: ECHConfigList+echConfList =+ fromJust $+ decodeECHConfigList $+ B64.decodeLenient+ "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA"
test/Run.hs view
@@ -6,8 +6,11 @@ runTLSSimple, runTLSPredicate, runTLSSimple13,+ runTLSSimple13ECH, runTLS0RTT,+ runTLS0RTTech, runTLSSimpleKeyUpdate,+ runTLSCaptureFail, runTLSCapture13, runTLSSuccess, runTLSFailure,@@ -118,6 +121,25 @@ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode +runTLSSimple13ECH+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> IO ()+runTLSSimple13ECH params mode =+ runTLSSuccess params hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ minfo <- contextGetInformation ctx+ let mmode = minfo >>= infoTLS13HandshakeMode+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ hsServer ctx = do+ handshake ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "S: mode should be Just" mode mmode+ runTLS0RTT :: (ClientParams, ServerParams) -> HandshakeMode13@@ -149,10 +171,67 @@ | len > 0 = [len] | otherwise = [] +runTLS0RTTech+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> ByteString+ -> IO ()+runTLS0RTTech params mode earlyData =+ withPairContext params $ \(cCtx, sCtx) ->+ concurrently_ (tlsServer sCtx) (tlsClient cCtx)+ where+ tlsClient ctx = do+ handshake ctx+ sendData ctx $ L.fromStrict earlyData+ _ <- recvData ctx+ bye ctx+ minfo <- contextGetInformation ctx+ let mmode = minfo >>= infoTLS13HandshakeMode+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ tlsServer ctx = do+ handshake ctx+ let ls = chunkLengths $ B.length earlyData+ chunks <- replicateM (length ls) $ recvData ctx+ (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData)+ sendData ctx $ L.fromStrict earlyData+ bye ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "S: mode should be Just" mode mmode+ chunkLengths :: Int -> [Int]+ chunkLengths len+ | len > 16384 = 16384 : chunkLengths (len - 16384)+ | len > 0 = [len]+ | otherwise = []+ expectMaybe :: (Show a, Eq a) => String -> a -> Maybe a -> Expectation expectMaybe tag e mx = case mx of Nothing -> expectationFailure tag Just x -> x `shouldBe` e++runTLSCaptureFail+ :: (ClientParams, ServerParams) -> IO ([Handshake], [Handshake])+runTLSCaptureFail params = do+ sRef <- newIORef []+ cRef <- newIORef []+ runTLSFailure params (hsClient cRef) (hsServer sRef)+ sReceived <- readIORef sRef+ cReceived <- readIORef cRef+ return (reverse sReceived, reverse cReceived)+ where+ hsClient ref ctx = do+ installHook ctx ref+ handshake ctx+ sendData ctx "Foo"+ hsServer ref ctx = do+ installHook ctx ref+ handshake ctx+ _ <- recvData ctx+ return ()+ installHook ctx ref =+ let recv hss = modifyIORef ref (hss :) >> return hss+ in contextHookSetHandshakeRecv ctx recv runTLSCapture13 :: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13])
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.1.8+version: 2.1.9 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -20,7 +20,7 @@ source-repository head type: git location: https://github.com/haskell-tls/hs-tls- subdir: core+ subdir: tls flag devel description: Development commands@@ -64,7 +64,6 @@ Network.TLS.Handshake.Common13 Network.TLS.Handshake.Control Network.TLS.Handshake.Key- Network.TLS.Handshake.Process Network.TLS.Handshake.Random Network.TLS.Handshake.Server Network.TLS.Handshake.Server.ClientHello@@ -78,6 +77,7 @@ Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13+ Network.TLS.Handshake.TranscriptHash Network.TLS.HashAndSignature Network.TLS.Hooks Network.TLS.IO@@ -128,9 +128,12 @@ crypton-x509-store >= 1.6 && < 1.7, crypton-x509-validation >= 1.6.13 && < 1.7, data-default,+ ech-config,+ hpke, memory >= 0.18 && < 0.19, mtl >= 2.2 && < 2.4, network >= 3.1,+ random >= 1.3 && < 1.4, serialise >= 0.2 && < 0.3, transformers >= 0.5 && < 0.7, unix-time >= 0.4.11 && < 0.5,@@ -146,6 +149,7 @@ Arbitrary Certificate CiphersSpec+ ECHSpec EncodeSpec HandshakeSpec PipeChan@@ -162,10 +166,12 @@ QuickCheck, asn1-types, async,+ base64-bytestring, bytestring, crypton, crypton-x509, crypton-x509-validation,+ ech-config, hourglass, hspec, serialise,@@ -190,6 +196,7 @@ crypton, crypton-x509-store, crypton-x509-system,+ ech-config, network, network-run, tls@@ -217,8 +224,9 @@ crypton, crypton-x509-store, crypton-x509-system,+ ech-config, network,- network-run,+ network-run >= 0.4.4, tls if flag(devel)
util/Client.hs view
@@ -9,6 +9,7 @@ ) where import qualified Data.ByteString.Base16 as BS16+import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as CL8 import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE@@ -30,14 +31,15 @@ clientHTTP11 :: Cli clientHTTP11 aux@Aux{..} paths ctx = do sendData ctx $- "GET "- <> CL8.fromStrict (NE.head paths)- <> " HTTP/1.1\r\n"- <> "Host: "- <> CL8.pack auxAuthority- <> "\r\n"- <> "Connection: close\r\n"- <> "\r\n"+ CL8.fromStrict $+ "GET "+ <> NE.head paths+ <> " HTTP/1.1\r\n"+ <> "Host: "+ <> C8.pack auxAuthority+ <> "\r\n"+ <> "Connection: close\r\n"+ <> "\r\n" consume ctx aux clientDNS :: Cli
util/Common.hs view
@@ -13,8 +13,11 @@ namedGroups, getInfo, printHandshakeInfo,+ showBytesHex, ) where +import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as C8 import Data.Char (isDigit) import Data.X509.CertificateStore import Network.TLS hiding (HostName)@@ -118,3 +121,7 @@ when (infoVersion i == TLS13) $ do putStrLn $ "Handshake mode: " ++ show (fromJust (infoTLS13HandshakeMode i)) putStrLn $ "Early data accepted: " ++ show (infoIsEarlyDataAccepted i)+ putStrLn $ "Encrypted client hello accepted: " ++ show (infoIsECHAccepted i)++showBytesHex :: ByteString -> String+showBytesHex bs = C8.unpack $ B16.encode bs
util/Server.hs view
@@ -4,7 +4,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.ByteString.Lazy.Char8 as CL8 import Data.IORef import Network.TLS import Prelude hiding (getLine)@@ -15,9 +15,9 @@ -- many TLS fragments. -- To prevent this, strict ByteString is created first and -- converted into lazy one.-html :: BL8.ByteString+html :: CL8.ByteString html =- BL8.fromStrict $+ CL8.fromStrict $ "HTTP/1.1 200 OK\r\n" <> "Context-Type: text/html\r\n" <> "Content-Length: "@@ -34,7 +34,7 @@ case C8.uncons bs of Nothing -> return () Just ('A', _) -> do- sendData ctx $ BL8.fromStrict bs+ sendData ctx $ CL8.fromStrict bs echo ctx Just _ -> handleHTML ctx showRequest bs @@ -44,7 +44,7 @@ loop = do bs <- recvData ctx when (bs /= "") $ do- sendData ctx $ BL8.fromStrict bs+ sendData ctx $ CL8.fromStrict bs loop handleHTML :: Context -> Bool -> ByteString -> IO ()@@ -57,6 +57,9 @@ when ("GET /keyupdate" `BS.isPrefixOf` bs) $ do r <- updateKey ctx TwoWay putStrLn $ "Updating key..." ++ if r then "OK" else "NG"+ when ("GET /secret" `BS.isPrefixOf` bs) $ do+ r <- requestCertificate ctx+ putStrLn $ "Post handshake authentication..." ++ if r then "OK" else "NG" when (bs /= "") $ do when showRequest $ do BS.putStr bs
util/tls-client.hs view
@@ -7,6 +7,7 @@ module Main where import Control.Concurrent+import qualified Control.Exception as E import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8 import Data.IORef@@ -16,6 +17,7 @@ import Network.Run.TCP import Network.Socket import Network.TLS hiding (is0RTTPossible)+import Network.TLS.ECH.Config import Network.TLS.Internal (makeCipherShowPretty) import System.Console.GetOpt import System.Environment@@ -40,6 +42,10 @@ , optALPN :: String , optCertFile :: Maybe FilePath , optKeyFile :: Maybe FilePath+ , optECHConfigFile :: Maybe FilePath+ , optTraceKey :: Bool+ , optIPv4Only :: Bool+ , optIPv6Only :: Bool } deriving (Show) @@ -59,6 +65,10 @@ , optALPN = "http/1.1" , optCertFile = Nothing , optKeyFile = Nothing+ , optECHConfigFile = Nothing+ , optTraceKey = False+ , optIPv4Only = False+ , optIPv6Only = False } usage :: String@@ -131,6 +141,26 @@ ["key"] (ReqArg (\fl o -> o{optKeyFile = Just fl}) "<file>") "key file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["trace-key"]+ (NoArg (\o -> o{optTraceKey = True}))+ "Trace transcript hash"+ , Option+ ['4']+ []+ (NoArg (\o -> o{optIPv4Only = True, optIPv6Only = False}))+ "IPv4 only"+ , Option+ ['6']+ []+ (NoArg (\o -> o{optIPv6Only = True, optIPv4Only = False}))+ "IPv6 only" ] showUsageAndExit :: String -> IO a@@ -169,6 +199,9 @@ let debug | optDebugLog = putStrLn | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return () showContent | optShow = C8.putStr | otherwise = \_ -> return ()@@ -182,7 +215,23 @@ } mstore <- if optValidate then Just <$> getSystemCertificateStore else return Nothing- let cparams = getClientParams opts host port (smIORef ref) mstore onCertReq+ echConfList <- case optECHConfigFile of+ Nothing -> return []+ Just ecnff ->+ loadECHConfigList ecnff `E.catch` \(E.SomeException _) -> do+ putStrLn $ ecnff ++ " is broken"+ exitFailure+ let cparams =+ getClientParams+ opts+ host+ port+ (smIORef ref)+ mstore+ onCertReq+ echConfList+ debug+ traceKey client | optALPN == "dot" = clientDNS | otherwise = clientHTTP11@@ -285,7 +334,7 @@ -> (Context -> IO a) -> IO a runTLS Options{..} cparams Aux{..} action =- runTCPClient auxAuthority auxPort $ \sock -> do+ runTCPClientWithSettings settings auxAuthority auxPort $ \sock -> do ctx <- contextNew sock cparams when optDebugLog $ contextHookSetLogging@@ -293,11 +342,26 @@ defaultLogging { loggingPacketSent = putStrLn . (">> " ++) , loggingPacketRecv = putStrLn . ("<< " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "}} " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "{{ " ++ show hd ++ " " ++ showBytesHex bs } handshake ctx r <- action ctx bye ctx return r+ where+ select addrs+ | optIPv4Only = case NE.filter (\ai -> addrFamily ai == AF_INET) addrs of+ [] -> error "IPv4 address is not available"+ ai : _ -> ai+ | optIPv6Only = case NE.filter (\ai -> addrFamily ai == AF_INET6) addrs of+ [] -> error "IPv6 address is not available"+ ai : _ -> ai+ | otherwise = NE.head addrs+ settings =+ defaultSettings+ { settingsSelectAddrInfo = select+ } modifyClientParams :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams@@ -314,14 +378,18 @@ -> SessionManager -> Maybe CertificateStore -> OnCertificateRequest+ -> ECHConfigList+ -> (String -> IO ())+ -> (String -> IO ()) -> ClientParams-getClientParams Options{..} serverName port sm mstore onCertReq =+getClientParams Options{..} serverName port sm mstore onCertReq echConfList printError traceKey = (defaultParamsClient serverName (C8.pack port)) { clientSupported = supported , clientUseServerNameIndication = True , clientShared = shared , clientHooks = hooks , clientDebug = debug+ , clientUseECH = not (null echConfList) } where groups@@ -334,6 +402,11 @@ Just store -> store Nothing -> mempty , sharedValidationCache = validateCache+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 8192+ }+ , sharedECHConfigList = echConfList } supported = defaultSupported@@ -354,6 +427,8 @@ debug = defaultDebugParams { debugKeyLogger = getLogger optKeyLogFile+ , debugError = printError+ , debugTraceKey = traceKey } smIORef :: IORef [(SessionID, SessionData)] -> SessionManager
util/tls-server.hs view
@@ -4,13 +4,12 @@ module Main where -import qualified Data.ByteString.Base16 as BS16-import qualified Data.ByteString.Char8 as C8 import Data.IORef import qualified Data.Map.Strict as M import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS+import Network.TLS.ECH.Config import Network.TLS.Internal import System.Console.GetOpt import System.Environment (getArgs)@@ -31,6 +30,9 @@ , optGroups :: [Group] , optCertFile :: FilePath , optKeyFile :: FilePath+ , optECHConfigFile :: Maybe FilePath+ , optECHKeyFile :: Maybe FilePath+ , optTraceKey :: Bool } deriving (Show) @@ -46,6 +48,9 @@ optGroups = FFDHE8192 `delete` supportedGroups defaultSupported , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem"+ , optECHConfigFile = Nothing+ , optECHKeyFile = Nothing+ , optTraceKey = False } options :: [OptDescr (Options -> Options)]@@ -90,6 +95,21 @@ ["trusted-anchor"] (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>") "trusted anchor file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["ech-key"]+ (ReqArg (\fl o -> o{optECHKeyFile = Just fl}) "<file>")+ "ECH key file"+ , Option+ []+ ["trace-key"]+ (NoArg (\o -> o{optTraceKey = True}))+ "Trace transcript hash" ] usage :: String@@ -120,20 +140,43 @@ exitFailure smgr <- newSessionManager Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile- mstore <-- if optClientAuth- then do- mstore' <- case optTrustedAnchor of- Nothing -> Just <$> getSystemCertificateStore- Just file -> readCertificateStore file- when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"- return mstore'- else return Nothing+ mstore <- do+ mstore' <- case optTrustedAnchor of+ Nothing -> Just <$> getSystemCertificateStore+ Just file -> readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ ech <- case optECHKeyFile of+ Nothing -> case optECHConfigFile of+ Nothing -> return ([], [])+ Just _ -> showUsageAndExit "must specify ECH key file, too"+ Just ekeyf -> case optECHConfigFile of+ Nothing -> showUsageAndExit "must specify ECH config file, too"+ Just ecnff -> do+ ekey <- loadECHSecretKeys [ekeyf]+ ecnf <- loadECHConfigList ecnff+ return (ekey, ecnf) let keyLog = getLogger optKeyLogFile+ printError+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return () creds = Credentials [cred] makeCipherShowPretty runTCPServer (Just host) port $ \sock -> do- let sparams = getServerParams creds optGroups smgr keyLog mstore+ let sparams =+ getServerParams+ creds+ optGroups+ smgr+ keyLog+ optClientAuth+ mstore+ ech+ printError+ traceKey ctx <- contextNew sock sparams when optDebugLog $ contextHookSetLogging@@ -141,6 +184,8 @@ defaultLogging { loggingPacketSent = putStrLn . ("<< " ++) , loggingPacketRecv = putStrLn . (">> " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "{{ " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "}} " ++ show hd ++ " " ++ showBytesHex bs } when (optDebugLog || optShow) $ putStrLn "------------------------" handshake ctx@@ -154,16 +199,21 @@ -> [Group] -> SessionManager -> (String -> IO ())+ -> Bool -> Maybe CertificateStore+ -> ([(Word8, ByteString)], ECHConfigList)+ -> (String -> IO ())+ -> (String -> IO ()) -> ServerParams-getServerParams creds groups sm keyLog mstore =+getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey = defaultParamsServer { serverSupported = supported , serverShared = shared , serverHooks = hooks , serverDebug = debug , serverEarlyDataSize = 2048- , serverWantClientCert = isJust mstore+ , serverWantClientCert = clientAuth+ , serverECHKey = ekey } where shared =@@ -173,6 +223,11 @@ , sharedCAStore = case mstore of Just store -> store Nothing -> sharedCAStore defaultShared+ , sharedECHConfigList = ecnf+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 16384+ } } supported = defaultSupported@@ -186,7 +241,12 @@ Just _ -> validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared) }- debug = defaultDebugParams{debugKeyLogger = keyLog}+ debug =+ defaultDebugParams+ { debugKeyLogger = keyLog+ , debugError = printError+ , debugTraceKey = traceKey+ } chooseALPN :: [ByteString] -> IO ByteString chooseALPN protos@@ -199,16 +259,12 @@ return $ noSessionManager { 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 }