mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-06 03:27:20 +00:00
185 lines
8.0 KiB
Diff
185 lines
8.0 KiB
Diff
diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Crypto.hs tls-fork/Network/TLS/Crypto.hs
|
|
--- tls-1.9.0-orig/Network/TLS/Crypto.hs 2026-09-30 18:44:40.083085887 +0000
|
|
+++ tls-fork/Network/TLS/Crypto.hs 2026-09-30 18:44:40.106519923 +0000
|
|
@@ -8,6 +8,7 @@
|
|
, hashUpdate
|
|
, hashUpdateSSL
|
|
, hashFinal
|
|
+ , hashCopy
|
|
|
|
, module Network.TLS.Crypto.DH
|
|
, module Network.TLS.Crypto.IES
|
|
@@ -44,6 +45,8 @@
|
|
import qualified Crypto.Hash as H
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteArray as B (convert)
|
|
+import qualified Data.ByteArray as BA
|
|
+import Unsafe.Coerce (unsafeCoerce)
|
|
import Crypto.Error
|
|
import Crypto.Number.Basic (numBits)
|
|
import Crypto.Random
|
|
@@ -135,6 +138,17 @@
|
|
hashUpdate (HashContextSSL sha1Ctx md5Ctx) b =
|
|
HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b)
|
|
|
|
+-- | Copies the context into a new allocation.
|
|
+hashCopy :: HashContext -> IO HashContext
|
|
+hashCopy (HashContext (ContextSimple h)) = HashContext . ContextSimple <$> copyContext h
|
|
+hashCopy (HashContextSSL sha1Ctx md5Ctx) = HashContextSSL <$> copyContext sha1Ctx <*> copyContext md5Ctx
|
|
+
|
|
+-- H.Context is a newtype over Bytes, with the constructor in a hidden crypton module
|
|
+copyContext :: H.Context alg -> IO (H.Context alg)
|
|
+copyContext h = do
|
|
+ b <- BA.copy h (\_ -> return ()) :: IO BA.Bytes
|
|
+ return $! unsafeCoerce b
|
|
+
|
|
hashUpdateSSL :: HashCtx
|
|
-> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context)
|
|
-> HashCtx
|
|
diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Handshake/Compact.hs tls-fork/Network/TLS/Handshake/Compact.hs
|
|
--- tls-1.9.0-orig/Network/TLS/Handshake/Compact.hs 1970-01-01 00:00:00.000000000 +0000
|
|
+++ tls-fork/Network/TLS/Handshake/Compact.hs 2026-09-30 18:45:10.137984909 +0000
|
|
@@ -0,0 +1,111 @@
|
|
+{-# LANGUAGE OverloadedStrings #-}
|
|
+{-# OPTIONS_HADDOCK hide #-}
|
|
+module Network.TLS.Handshake.Compact
|
|
+ ( compactContext
|
|
+ ) where
|
|
+
|
|
+import Control.Concurrent.MVar
|
|
+import Control.Exception (evaluate)
|
|
+import Crypto.Random (drgNew)
|
|
+import qualified Data.ByteString as B
|
|
+import Data.IORef
|
|
+
|
|
+import Network.TLS.Cipher
|
|
+import Network.TLS.Context.Internal
|
|
+import Network.TLS.Crypto
|
|
+import Network.TLS.Extension (Cookie (..))
|
|
+import Network.TLS.Handshake.State
|
|
+import Network.TLS.Imports
|
|
+import Network.TLS.KeySchedule (hkdfExpandLabel)
|
|
+import Network.TLS.Record.State
|
|
+import Network.TLS.RNG
|
|
+import Network.TLS.State
|
|
+import Network.TLS.Struct
|
|
+import Network.TLS.Types
|
|
+
|
|
+-- | Re-allocates the state a context keeps after the handshake, next to each other.
|
|
+-- Each small pinned value created during the handshake shares a 4K block with short-lived
|
|
+-- crypto temporaries, and keeps the whole block alive, with every dead ScrubbedBytes in it.
|
|
+compactContext :: Context -> IO ()
|
|
+compactContext ctx = do
|
|
+ tx <- readMVar $ ctxTxState ctx
|
|
+ rx <- readMVar $ ctxRxState ctx
|
|
+ st <- readMVar $ ctxState ctx
|
|
+ hst <- readMVar $ ctxHandshake ctx
|
|
+ finished <- readIORef $ ctxFinished ctx
|
|
+ peerFinished <- readIORef $ ctxPeerFinished ctx
|
|
+ -- key derivation and reseeding allocate temporaries, so they precede the copies
|
|
+ txKey <- trafficKey tx
|
|
+ rxKey <- trafficKey rx
|
|
+ rng <- evaluate $ StateRNG $ fst $ withTLSRNG (stRandomGen st) drgNew
|
|
+ tx' <- copyRecordState BulkEncrypt txKey tx
|
|
+ rx' <- copyRecordState BulkDecrypt rxKey rx
|
|
+ st' <- copyTLSState rng st
|
|
+ hst' <- traverse copyHandshakeState hst
|
|
+ finished' <- traverse copyBytes finished
|
|
+ peerFinished' <- traverse copyBytes peerFinished
|
|
+ modifyMVar_ (ctxTxState ctx) $ \_ -> return tx'
|
|
+ modifyMVar_ (ctxRxState ctx) $ \_ -> return rx'
|
|
+ modifyMVar_ (ctxState ctx) $ \_ -> return st'
|
|
+ modifyMVar_ (ctxHandshake ctx) $ \_ -> return hst'
|
|
+ writeIORef (ctxFinished ctx) finished'
|
|
+ writeIORef (ctxPeerFinished ctx) peerFinished'
|
|
+
|
|
+copyBytes :: ByteString -> IO ByteString
|
|
+copyBytes = evaluate . B.copy
|
|
+
|
|
+-- TLS 1.3 record keys are derived from the traffic secret kept in the record state;
|
|
+-- earlier versions keep the bulk key only inside the cipher state.
|
|
+trafficKey :: RecordState -> IO (Maybe ByteString)
|
|
+trafficKey RecordState{stCipher = Just cipher, stCryptLevel = CryptApplicationSecret, stCryptState = cst} =
|
|
+ Just <$> evaluate (hkdfExpandLabel (cipherHash cipher) (cstMacSecret cst) "key" "" (bulkKeySize $ cipherBulk cipher))
|
|
+trafficKey _ = return Nothing
|
|
+
|
|
+copyRecordState :: BulkDirection -> Maybe ByteString -> RecordState -> IO RecordState
|
|
+copyRecordState dir key_ rs@RecordState{stCryptState = cst} = do
|
|
+ iv <- copyBytes $ cstIV cst
|
|
+ secret <- copyBytes $ cstMacSecret cst
|
|
+ bulkState <- case (key_, stCipher rs) of
|
|
+ (Just key, Just cipher) -> bulkInit (cipherBulk cipher) dir <$> copyBytes key
|
|
+ _ -> return $ cstKey cst
|
|
+ evaluate rs{stCryptState = CryptState{cstKey = bulkState, cstIV = iv, cstMacSecret = secret}}
|
|
+
|
|
+copyTLSState :: StateRNG -> TLSState -> IO TLSState
|
|
+copyTLSState rng st = do
|
|
+ session <- case stSession st of
|
|
+ Session sid -> Session <$> traverse copyBytes sid
|
|
+ clientVerified <- copyBytes $ stClientVerifiedData st
|
|
+ serverVerified <- copyBytes $ stServerVerifiedData st
|
|
+ proto <- traverse copyBytes $ stNegotiatedProtocol st
|
|
+ alpn <- traverse (traverse copyBytes) $ stClientALPNSuggest st
|
|
+ cookie <- traverse (\(Cookie c) -> Cookie <$> copyBytes c) $ stTLS13Cookie st
|
|
+ exporter <- traverse copyBytes $ stExporterMasterSecret st
|
|
+ evaluate
|
|
+ st
|
|
+ { stSession = session
|
|
+ , stClientVerifiedData = clientVerified
|
|
+ , stServerVerifiedData = serverVerified
|
|
+ , stNegotiatedProtocol = proto
|
|
+ , stClientALPNSuggest = alpn
|
|
+ , stTLS13Cookie = cookie
|
|
+ , stExporterMasterSecret = exporter
|
|
+ , stRandomGen = rng
|
|
+ }
|
|
+
|
|
+copyHandshakeState :: HandshakeState -> IO HandshakeState
|
|
+copyHandshakeState hst = do
|
|
+ clientRandom <- ClientRandom <$> copyBytes (unClientRandom $ hstClientRandom hst)
|
|
+ serverRandom <- traverse (fmap ServerRandom . copyBytes . unServerRandom) $ hstServerRandom hst
|
|
+ mainSecret <- traverse copyBytes $ hstMasterSecret hst
|
|
+ digest <- case hstHandshakeDigest hst of
|
|
+ HandshakeMessages msgs -> HandshakeMessages <$> traverse copyBytes msgs
|
|
+ HandshakeDigestContext h -> HandshakeDigestContext <$> hashCopy h
|
|
+ resumption <- traverse (\(BaseSecret s) -> BaseSecret <$> copyBytes s) $ hstTLS13ResumptionSecret hst
|
|
+ evaluate
|
|
+ hst
|
|
+ { hstClientRandom = clientRandom
|
|
+ , hstServerRandom = serverRandom
|
|
+ , hstMasterSecret = mainSecret
|
|
+ , hstHandshakeDigest = digest
|
|
+ , hstTLS13ResumptionSecret = resumption
|
|
+ }
|
|
diff -ruN -x 'dist*' tls-1.9.0-orig/Network/TLS/Handshake.hs tls-fork/Network/TLS/Handshake.hs
|
|
--- tls-1.9.0-orig/Network/TLS/Handshake.hs 2026-09-30 18:44:40.083878116 +0000
|
|
+++ tls-fork/Network/TLS/Handshake.hs 2026-09-30 18:45:14.390780619 +0000
|
|
@@ -18,6 +18,7 @@
|
|
import Network.TLS.Struct
|
|
|
|
import Network.TLS.Handshake.Common
|
|
+import Network.TLS.Handshake.Compact
|
|
import Network.TLS.Handshake.Client
|
|
import Network.TLS.Handshake.Server
|
|
|
|
@@ -27,7 +28,7 @@
|
|
-- This is to be called at the beginning of a connection, and during renegotiation
|
|
handshake :: MonadIO m => Context -> m ()
|
|
handshake ctx =
|
|
- liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx)
|
|
+ liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) >> compactContext ctx
|
|
|
|
-- Handshake when requested by the remote end
|
|
-- This is called automatically by 'recvData', in a context where the read lock
|
|
diff -ruN -x 'dist*' tls-1.9.0-orig/tls.cabal tls-fork/tls.cabal
|
|
--- tls-1.9.0-orig/tls.cabal 2026-09-30 18:44:40.090442445 +0000
|
|
+++ tls-fork/tls.cabal 2026-09-30 19:12:16.099341583 +0000
|
|
@@ -85,6 +85,7 @@
|
|
Network.TLS.Handshake.Signature
|
|
Network.TLS.Handshake.State
|
|
Network.TLS.Handshake.State13
|
|
+ Network.TLS.Handshake.Compact
|
|
Network.TLS.Hooks
|
|
Network.TLS.IO
|
|
Network.TLS.Imports
|