tls 1.5.0 → 1.5.1
raw patch · 44 files changed
+1240/−702 lines, 44 files
Files
- CHANGELOG.md +8/−0
- Network/TLS.hs +3/−1
- Network/TLS/Context.hs +17/−0
- Network/TLS/Context/Internal.hs +44/−4
- Network/TLS/Core.hs +29/−8
- Network/TLS/Credentials.hs +4/−4
- Network/TLS/Extension.hs +11/−0
- Network/TLS/Extra/Cipher.hs +11/−4
- Network/TLS/Handshake.hs +0/−20
- Network/TLS/Handshake/Certificate.hs +8/−2
- Network/TLS/Handshake/Client.hs +232/−176
- Network/TLS/Handshake/Common.hs +34/−7
- Network/TLS/Handshake/Common13.hs +87/−28
- Network/TLS/Handshake/Process.hs +3/−3
- Network/TLS/Handshake/Random.hs +2/−5
- Network/TLS/Handshake/Server.hs +156/−83
- Network/TLS/Handshake/State.hs +12/−1
- Network/TLS/Handshake/State13.hs +13/−8
- Network/TLS/Hooks.hs +5/−1
- Network/TLS/IO.hs +90/−43
- Network/TLS/Internal.hs +4/−0
- Network/TLS/Parameters.hs +13/−4
- Network/TLS/PostHandshake.hs +39/−0
- Network/TLS/Receiving13.hs +9/−7
- Network/TLS/Record/Disengage.hs +42/−5
- Network/TLS/Record/Disengage13.hs +0/−77
- Network/TLS/Record/Engage.hs +41/−11
- Network/TLS/Record/Engage13.hs +0/−69
- Network/TLS/Record/State.hs +20/−10
- Network/TLS/Record/Types.hs +4/−0
- Network/TLS/Record/Types13.hs +0/−24
- Network/TLS/Sending.hs +22/−11
- Network/TLS/Sending13.hs +35/−23
- Network/TLS/State.hs +10/−0
- Network/TLS/Struct.hs +3/−0
- Network/TLS/Struct13.hs +5/−35
- Network/TLS/Types.hs +4/−0
- Network/TLS/Util.hs +32/−3
- Network/TLS/X509.hs +3/−0
- Tests/Certificate.hs +1/−0
- Tests/Connection.hs +2/−2
- Tests/Marshalling.hs +89/−15
- Tests/Tests.hs +91/−4
- tls.cabal +2/−4
CHANGELOG.md view
@@ -1,3 +1,11 @@+## Version 1.5.1++- Post-handshake authentication [#363](https://github.com/vincenthz/hs-tls/pull/363)+- Fixing memory leak [#366](https://github.com/vincenthz/hs-tls/pull/366)+- Improve version negotiation [#368](https://github.com/vincenthz/hs-tls/pull/368)+- Don't send 0-RTT data when ticket is expired [#370](https://github.com/vincenthz/hs-tls/pull/370)+- Handshake packet fragmentation [#371](https://github.com/vincenthz/hs-tls/pull/371)+ ## Version 1.5.0 - Add and enable AES CCM ciphers [#271](https://github.com/vincenthz/hs-tls/pull/271) [#287](https://github.com/vincenthz/hs-tls/pull/287)
Network/TLS.hs view
@@ -56,6 +56,7 @@ , Handshake , Logging(..) , contextHookSetHandshakeRecv+ , contextHookSetHandshake13Recv , contextHookSetCertificateRecv , contextHookSetLogging , contextModifyHooks@@ -98,9 +99,10 @@ -- ** Negotiated , getNegotiatedProtocol , getClientSNI- -- ** Updating keys+ -- ** Post-handshake actions , updateKey , KeyUpdateRequest(..)+ , requestCertificate -- * Raw types , ProtocolType(..)
Network/TLS/Context.hs view
@@ -49,6 +49,7 @@ -- * Context hooks , contextHookSetHandshakeRecv+ , contextHookSetHandshake13Recv , contextHookSetCertificateRecv , contextHookSetLogging @@ -67,6 +68,7 @@ import Network.TLS.Backend import Network.TLS.Context.Internal import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.State import Network.TLS.Hooks import Network.TLS.Record.State@@ -74,6 +76,7 @@ import Network.TLS.Measurement import Network.TLS.Types (Role(..)) import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith)+import Network.TLS.PostHandshake (requestCertificateServer, postHandshakeAuthClientWith, postHandshakeAuthServerWith) import Network.TLS.X509 import Network.TLS.RNG @@ -92,6 +95,8 @@ getTLSRole :: a -> Role doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> Handshake -> IO ()+ doRequestCertificate :: a -> Context -> IO Bool+ doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams = ( clientSupported cparams@@ -101,6 +106,8 @@ getTLSRole _ = ClientRole doHandshake = handshakeClient doHandshakeWith = handshakeClientWith+ doRequestCertificate _ _ = return False+ doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where getTLSCommonParams sparams = ( serverSupported sparams@@ -110,6 +117,8 @@ getTLSRole _ = ServerRole doHandshake = handshakeServer doHandshakeWith = handshakeServerWith+ doRequestCertificate = requestCertificateServer+ doPostHandshakeAuthWith = postHandshakeAuthServerWith -- | create a new context using the backend and parameters specified. contextNew :: (MonadIO m, HasBackend backend, TLSParams params)@@ -144,6 +153,7 @@ rx <- newMVar newRecordState hs <- newMVar Nothing as <- newIORef []+ crs <- newIORef [] lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar ()@@ -158,6 +168,8 @@ , ctxHandshake = hs , ctxDoHandshake = doHandshake params , ctxDoHandshakeWith = doHandshakeWith params+ , ctxDoRequestCertificate = doRequestCertificate params+ , ctxDoPostHandshakeAuthWith = doPostHandshakeAuthWith params , ctxMeasurement = stats , ctxEOF_ = eof , ctxEstablished_ = established@@ -168,6 +180,7 @@ , ctxLockRead = lockRead , ctxLockState = lockState , ctxPendingActions = as+ , ctxCertRequests = crs , ctxKeyLogger = debugKeyLogger debug } @@ -192,6 +205,10 @@ contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = contextModifyHooks context (\hooks -> hooks { hookRecvHandshake = f })++contextHookSetHandshake13Recv :: Context -> (Handshake13 -> IO Handshake13) -> IO ()+contextHookSetHandshake13Recv context f =+ contextModifyHooks context (\hooks -> hooks { hookRecvHandshake13 = f }) contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO () contextHookSetCertificateRecv context f =
Network/TLS/Context/Internal.hs view
@@ -21,7 +21,7 @@ , Context(..) , Hooks(..) , Established(..)- , PendingAction+ , PendingAction(..) , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello@@ -48,14 +48,19 @@ -- * Using context states , throwCore+ , failOnEitherError , usingState , usingState_ , runTxState , runRxState , usingHState , getHState+ , saveHState+ , restoreHState , getStateRNG , tls13orLater+ , addCertRequest13+ , getCertRequest13 ) where import Network.TLS.Backend@@ -71,6 +76,8 @@ import Network.TLS.Parameters import Network.TLS.Measurement import Network.TLS.Imports+import Network.TLS.Types+import Network.TLS.Util import qualified Data.ByteString as B import Control.Concurrent.MVar@@ -111,12 +118,15 @@ , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state , ctxDoHandshake :: Context -> IO () , ctxDoHandshakeWith :: Context -> Handshake -> IO ()+ , ctxDoRequestCertificate :: Context -> IO Bool+ , ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO () , ctxHooks :: IORef Hooks -- ^ hooks for this context , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state) , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. -- it is usually nested in a write or read lock. , ctxPendingActions :: IORef [PendingAction]+ , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests , ctxKeyLogger :: String -> IO () } @@ -126,7 +136,11 @@ | Established deriving (Eq, Show) -type PendingAction = (Handshake13 -> IO (), IO ())+data PendingAction+ = PendingAction Bool (Handshake13 -> IO ())+ -- ^ simple pending action+ | PendingActionHash Bool (ByteString -> Handshake13 -> IO ())+ -- ^ pending action taking transcript hash up to preceding message updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do@@ -225,6 +239,14 @@ getHState :: MonadIO m => Context -> m (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx) +saveHState :: Context -> IO (Saved (Maybe HandshakeState))+saveHState ctx = saveMVar (ctxHandshake ctx)++restoreHState :: Context+ -> Saved (Maybe HandshakeState)+ -> IO (Saved (Maybe HandshakeState))+restoreHState ctx = restoreMVar (ctxHandshake ctx)+ runTxState :: Context -> RecordM a -> IO (Either TLSError a) runTxState ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)@@ -235,8 +257,11 @@ let ver' | ver >= TLS13 = if hrr then TLS12 else TLS10 | otherwise = ver+ opt = RecordOptions { recordVersion = ver'+ , recordTLS13 = ver >= TLS13+ } modifyMVar (ctxTxState ctx) $ \st ->- case runRecordM f ver' st of+ case runRecordM f opt st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) @@ -244,8 +269,11 @@ runRxState ctx f = do ver <- usingState_ ctx getVersion -- For 1.3, ver is just ignored. So, it is not necessary to convert ver.+ let opt = RecordOptions { recordVersion = ver+ , recordTLS13 = ver >= TLS13+ } modifyMVar (ctxRxState ctx) $ \st ->- case runRecordM f ver st of+ case runRecordM f opt st of Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) @@ -270,3 +298,15 @@ return $ case ev of 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 (\(CertRequest13 c _) -> context == c) l+ case matched of+ [] -> return Nothing+ (certReq:_) -> writeIORef ref others >> return (Just certReq)
Network/TLS/Core.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-} -- | -- Module : Network.TLS.Core -- License : BSD-style@@ -29,6 +29,7 @@ , recvData' , updateKey , KeyUpdateRequest(..)+ , requestCertificate ) where import Network.TLS.Cipher@@ -46,6 +47,7 @@ import Network.TLS.Handshake.Process import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.PostHandshake import Network.TLS.KeySchedule import Network.TLS.Types (Role(..), HostName) import Network.TLS.Util (catchException, mapChunks_)@@ -198,12 +200,15 @@ maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms _ -> 0- tinfo <- createTLS13TicketInfo life (Right add) Nothing+ life7d = min life 604800 -- 7 days max+ tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk- sessionEstablish (sharedSessionManager $ ctxShared ctx) label sdata+ let !label' = B.copy label+ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" loopHandshake13 hs loopHandshake13 (KeyUpdate13 mode:hs) = do+ checkAlignment hs established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -221,21 +226,37 @@ else do let reason = "received key update before established" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ loopHandshake13 (h@CertRequest13{}:hs) =+ postHandshakeAuthWith ctx h >> loopHandshake13 hs+ loopHandshake13 (h@Certificate13{}:hs) =+ postHandshakeAuthWith ctx h >> loopHandshake13 hs loopHandshake13 (h:hs) = do mPendingAction <- popPendingAction ctx case mPendingAction of Nothing -> let reason = "unexpected handshake message " ++ show h in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Just (pa, postAction) -> do+ Just action -> do -- Pending actions are executed with read+write locks, just -- like regular handshake code.- withWriteLock ctx $ do- pa h- processHandshake13 ctx h- postAction+ withWriteLock ctx $ handleException ctx $+ case action of+ PendingAction needAligned pa -> do+ when needAligned $ checkAlignment hs+ processHandshake13 ctx h >> pa h+ PendingActionHash needAligned pa -> do+ when needAligned $ checkAlignment hs+ d <- transcriptHash ctx+ processHandshake13 ctx h+ pa d h loopHandshake13 hs terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)++ checkAlignment hs = do+ complete <- isRecvComplete ctx+ unless (complete && null hs) $+ let reason = "received message not aligned with record boundary"+ in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions
Network/TLS/Credentials.hs view
@@ -116,7 +116,7 @@ | KeyUsage_keyEncipherment `elem` flags -> Just () | otherwise -> Nothing _ -> Nothing- where cert = signedObject $ getSigned signed+ where cert = getCertificate signed pub = certPubKey cert signed = getCertificateChainLeaf chain @@ -127,13 +127,13 @@ Just (ExtKeyUsage flags) | KeyUsage_digitalSignature `elem` flags -> findKeyExchangeSignatureAlg (pub, priv) | otherwise -> Nothing- where cert = signedObject $ getSigned signed+ where cert = getCertificate signed pub = certPubKey cert signed = getCertificateChainLeaf chain credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey) credentialPublicPrivateKeys (chain, priv) = pub `seq` (pub, priv)- where cert = signedObject $ getSigned signed+ where cert = getCertificate signed pub = certPubKey cert signed = getCertificateChainLeaf chain @@ -176,5 +176,5 @@ Just hs -> hs `elem` hashSigs isSelfSigned signed =- let cert = signedObject $ getSigned signed+ let cert = getCertificate signed in certSubjectDN cert == certIssuerDN cert
Network/TLS/Extension.hs view
@@ -51,6 +51,7 @@ , KeyShare(..) , KeyShareEntry(..) , MessageType(..)+ , PostHandshakeAuth(..) , PskKexMode(..) , PskKeyExchangeModes(..) , PskIdentity(..)@@ -463,6 +464,16 @@ decodeSignatureAlgorithms = runGetMaybe $ do len <- getWord16 SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++------------------------------------------------------------++data PostHandshakeAuth = PostHandshakeAuth deriving (Show,Eq)++instance Extension PostHandshakeAuth where+ extensionID _ = extensionID_PostHandshakeAuth+ extensionEncode _ = B.empty+ extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth+ extensionDecode _ = error "extensionDecode: PostHandshakeAuth" ------------------------------------------------------------
Network/TLS/Extra/Cipher.hs view
@@ -482,6 +482,13 @@ , bulkF = BulkAeadF chacha20poly1305 } +-- TLS13 bulks are same as TLS12 except they never have explicit IV+bulk_aes128gcm_13, bulk_aes256gcm_13, bulk_aes128ccm_13, bulk_aes128ccm8_13 :: Bulk+bulk_aes128gcm_13 = bulk_aes128gcm { bulkIVSize = 12, bulkExplicitIV = 0 }+bulk_aes256gcm_13 = bulk_aes256gcm { bulkIVSize = 12, bulkExplicitIV = 0 }+bulk_aes128ccm_13 = bulk_aes128ccm { bulkIVSize = 12, bulkExplicitIV = 0 }+bulk_aes128ccm8_13 = bulk_aes128ccm8 { bulkIVSize = 12, bulkExplicitIV = 0 }+ -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher@@ -836,7 +843,7 @@ cipher_TLS13_AES128GCM_SHA256 = Cipher { cipherID = 0x1301 , cipherName = "AES128GCM-SHA256"- , cipherBulk = bulk_aes128gcm+ , cipherBulk = bulk_aes128gcm_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13@@ -847,7 +854,7 @@ cipher_TLS13_AES256GCM_SHA384 = Cipher { cipherID = 0x1302 , cipherName = "AES256GCM-SHA384"- , cipherBulk = bulk_aes256gcm+ , cipherBulk = bulk_aes256gcm_13 , cipherHash = SHA384 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13@@ -869,7 +876,7 @@ cipher_TLS13_AES128CCM_SHA256 = Cipher { cipherID = 0x1304 , cipherName = "AES128CCM-SHA256"- , cipherBulk = bulk_aes128ccm+ , cipherBulk = bulk_aes128ccm_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13@@ -880,7 +887,7 @@ cipher_TLS13_AES128CCM8_SHA256 = Cipher { cipherID = 0x1305 , cipherName = "AES128CCM8-SHA256"- , cipherBulk = bulk_aes128ccm8+ , cipherBulk = bulk_aes128ccm8_13 , cipherHash = SHA256 , cipherPRFHash = Nothing , cipherKeyExchange = CipherKeyExchange_TLS13
Network/TLS/Handshake.hs view
@@ -16,17 +16,12 @@ import Network.TLS.Context.Internal import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.IO-import Network.TLS.Util (catchException)-import Network.TLS.Imports import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict-import Control.Exception (IOException, handle, fromException) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation@@ -41,18 +36,3 @@ handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs = liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoHandshakeWith ctx ctx hs--handleException :: Context -> IO () -> IO ()-handleException ctx f = catchException f $ \exception -> do- let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception- setEstablished ctx NotEstablished- handle ignoreIOErr $ do- tls13 <- tls13orLater ctx- if tls13 then- sendPacket13 ctx $ Alert13 $ errorToAlert tlserror- else- sendPacket ctx $ Alert $ errorToAlert tlserror- handshakeFailed tlserror- where- ignoreIOErr :: IOException -> IO ()- ignoreIOErr _ = return ()
Network/TLS/Handshake/Certificate.hs view
@@ -10,6 +10,7 @@ , badCertificate , rejectOnException , verifyLeafKeyUsage+ , extractCAname ) where import Network.TLS.Context.Internal@@ -17,7 +18,7 @@ import Network.TLS.X509 import Control.Monad.State.Strict import Control.Exception (SomeException)-import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet, getSigned, signedObject)+import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a@@ -27,6 +28,8 @@ throwCore $ Error_Protocol ("certificate has expired", True, CertificateExpired) certificateRejected CertificateRejectUnknownCA = throwCore $ Error_Protocol ("certificate has unknown CA", True, UnknownCa)+certificateRejected CertificateRejectAbsent =+ throwCore $ Error_Protocol ("certificate is missing", True, CertificateRequired) certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) @@ -42,8 +45,11 @@ unless verified $ badCertificate $ "certificate is not allowed for any of " ++ show validFlags where- cert = signedObject $ getSigned signed+ cert = getCertificate signed verified = case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags++extractCAname :: SignedCertificate -> DistinguishedName+extractCAname cert = certSubjectDN $ getCertificate cert
Network/TLS/Handshake/Client.hs view
@@ -10,6 +10,7 @@ module Network.TLS.Handshake.Client ( handshakeClient , handshakeClientWith+ , postHandshakeAuthClientWith ) where import Network.TLS.Crypto@@ -34,7 +35,7 @@ import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict-import Control.Exception (SomeException)+import Control.Exception (SomeException, bracket) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13@@ -71,20 +72,25 @@ -- ClientHello without modification, except as follows:" -- -- So, the ClientRandom in the first client hello is necessary.-handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO ()-handshakeClient' cparams ctx groups mcrand = do+handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO ()+handshakeClient' cparams ctx groups mparams = do updateMeasure ctx incrementNbHandshakes- sentExtensions <- sendClientHello mcrand- recvServerHello sentExtensions+ (crand, clientSession) <- generateClientHelloParams+ (rtt0, sentExtensions) <- sendClientHello clientSession crand+ recvServerHello clientSession sentExtensions ver <- usingState_ ctx getVersion+ unless (maybe True (\(_, _, v) -> v == ver) mparams) $+ throwCore $ Error_Protocol ("version changed after hello retry", True, 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- if ver == TLS13 then do+ if ver == TLS13 then if hrr then case drop 1 groups of [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter) groups' -> do+ when (isJust mparams) $+ throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage) mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)@@ -92,14 +98,16 @@ usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxState ctx let cparams' = cparams { clientEarlyData = Nothing }- crand <- usingHState ctx $ hstClientRandom <$> get- handshakeClient' cparams' ctx [selectedGroup] (Just crand)+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx+ handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter) Just _ -> error "handshakeClient': invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure) else do- handshakeClient13 cparams ctx+ handshakeClient13 cparams ctx groupToSend else do+ when rtt0 $+ throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure) sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx ClientRole@@ -111,21 +119,24 @@ compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13- getExtensions = sequence [sniExtension- ,secureReneg- ,alpnExtension- ,groupExtension- ,ecPointExtension- --,sessionTicketExtension- ,signatureAlgExtension- -- ,heartbeatExtension- ,versionExtension- ,earlyDataExtension- ,keyshareExtension- ,pskExchangeModeExtension- ,cookieExtension- ,preSharedKeyExtension -- MUST be last- ]+ groupToSend = listToMaybe groups+ getExtensions pskInfo rtt0 = sequence+ [ sniExtension+ , secureReneg+ , alpnExtension+ , groupExtension+ , ecPointExtension+ --, sessionTicketExtension+ , signatureAlgExtension+ --, heartbeatExtension+ , versionExtension+ , earlyDataExtension rtt0+ , keyshareExtension+ , pskExchangeModeExtension+ , cookieExtension+ , postHandshakeAuthExtension+ , preSharedKeyExtension pskInfo -- MUST be last+ ] toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)@@ -157,15 +168,15 @@ versionExtension | tls13 = do- let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx+ let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers | otherwise = return Nothing -- FIXME keyshareExtension- | tls13 = case groups of- [] -> return Nothing- grp:_ -> do+ | tls13 = case groupToSend of+ Nothing -> return Nothing+ Just grp -> do (cpri, ent) <- makeClientKeyShare ctx grp usingHState ctx $ setGroupPrivate cpri return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]@@ -178,30 +189,34 @@ sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers return (sid, sdata, sCipher) - preSharedKeyExtension =+ getPskInfo = case sessionAndCipherToResume13 of Nothing -> return Nothing Just (sid, sdata, sCipher) -> do- let usedHash = cipherHash sCipher- siz = hashDigestSize usedHash- zero = B.replicate siz 0- tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata- age <- getAge tinfo- if isAgeValid age tinfo then do- let obfAge = ageToObfuscatedAge age tinfo- let identity = PskIdentity sid obfAge- offeredPsks = PreSharedKeyClientHello [identity] [zero]- return $ Just $ toExtensionRaw offeredPsks- else- return Nothing+ let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata+ age <- getAge tinfo+ return $ if isAgeValid age tinfo+ then Just (sid, sdata, sCipher, ageToObfuscatedAge age tinfo)+ else Nothing + preSharedKeyExtension pskInfo =+ case pskInfo of+ Nothing -> return Nothing+ Just (sid, _, sCipher, obfAge) ->+ let usedHash = cipherHash sCipher+ siz = hashDigestSize usedHash+ zero = B.replicate siz 0+ identity = PskIdentity sid obfAge+ offeredPsks = PreSharedKeyClientHello [identity] [zero]+ in return $ Just $ toExtensionRaw offeredPsks+ pskExchangeModeExtension | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] | otherwise = return Nothing - earlyDataExtension = case check0RTT of- Nothing -> return Nothing- _ -> return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)+ earlyDataExtension rtt0+ | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)+ | otherwise = return Nothing cookieExtension = do mcookie <- usingState_ ctx getTLS13Cookie@@ -209,16 +224,14 @@ Nothing -> return Nothing Just cookie -> return $ Just $ toExtensionRaw cookie - clientSession = case clientWantSessionResume cparams of- Nothing -> Session Nothing- Just (sid, sdata)- | sessionVersion sdata >= TLS13 -> Session Nothing- | otherwise -> Session (Just sid)+ postHandshakeAuthExtension+ | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth+ | otherwise = return Nothing - adjustExtentions exts ch =- case sessionAndCipherToResume13 of+ adjustExtentions pskInfo exts ch =+ case pskInfo of Nothing -> return exts- Just (_, sdata, sCipher) -> do+ Just (_, sdata, sCipher, _) -> do let usedHash = cipherHash sCipher siz = hashDigestSize usedHash zero = B.replicate siz 0@@ -233,8 +246,27 @@ withBinders = replacePSKBinder withoutBinders binder return exts' - sendClientHello mcr = do- crand <- clientRandom ctx mcr+ generateClientHelloParams =+ case mparams of+ -- Client random and session in the second client hello for+ -- retry must be the same as the first one.+ Just (crand, clientSession, _) -> return (crand, clientSession)+ Nothing -> do+ crand <- clientRandom ctx+ let paramSession = case clientWantSessionResume cparams of+ Nothing -> Session Nothing+ Just (sid, sdata)+ | sessionVersion sdata >= TLS13 -> Session Nothing+ | otherwise -> Session (Just sid)+ -- In compatibility mode a client not offering a pre-TLS 1.3+ -- session MUST generate a new 32-byte value+ if tls13 && paramSession == Session Nothing+ then do+ randomSession <- newSession ctx+ return (crand, randomSession)+ else return (crand, paramSession)++ sendClientHello clientSession crand = do let ver = if tls13 then TLS12 else highestVer hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand@@ -242,21 +274,21 @@ let cipherIds = map cipherID ciphers compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing- extensions0 <- catMaybes <$> getExtensions- extensions <- adjustExtentions extensions0 $ mkClientHello extensions0+ pskInfo <- getPskInfo+ let rtt0info = pskInfo >>= get0RTTinfo+ rtt0 = isJust rtt0info+ extensions0 <- catMaybes <$> getExtensions pskInfo rtt0+ extensions <- adjustExtentions pskInfo extensions0 $ mkClientHello extensions0 sendPacket ctx $ Handshake [mkClientHello extensions]- send0RTT- return $ map (\(ExtensionRaw i _) -> i) extensions+ mapM_ send0RTT rtt0info+ return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) - check0RTT = do- (_, sdata, sCipher) <- sessionAndCipherToResume13+ get0RTTinfo (_, sdata, sCipher, _) = do earlyData <- clientEarlyData cparams guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) return (sCipher, earlyData) - send0RTT = case check0RTT of- Nothing -> return ()- Just (usedCipher, earlyData) -> do+ send0RTT (usedCipher, earlyData) = do let usedHash = cipherHash usedCipher -- fixme: not initialized yet -- hCh <- transcriptHash ctx@@ -265,14 +297,15 @@ EarlySecret earlySecret <- usingHState ctx getTLS13Secret -- fixme let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx setTxState ctx usedHash usedCipher clientEarlyTrafficSecret mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData usingHState ctx $ setTLS13RTT0Status RTT0Sent - recvServerHello sentExts = runRecvState ctx recvState+ recvServerHello clientSession sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of- Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs -- this adds SH to hstHandshakeMessages+ Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages Alert a -> case a of [(AlertLevel_Warning, UnrecognizedName)] ->@@ -280,7 +313,7 @@ then return recvState else throwAlert a _ -> throwAlert a- _ -> fail ("unexepected type received. expecting handshake and got: " ++ show p)+ _ -> unexpected (show p) (Just "handshake") throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) -- | Store the keypair and check that it is compatible with a list of@@ -490,7 +523,7 @@ case groupUsage of GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)- GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)+ GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter) GroupUsageValid -> return () -- When grp is known but not in the supported list we use it@@ -506,7 +539,7 @@ usingHState ctx $ setNegotiatedGroup grp dhePair <- generateFFDHEShared ctx grp srvpub case dhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just pair -> return pair masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster@@ -519,7 +552,7 @@ usingHState ctx $ setNegotiatedGroup grp ecdhePair <- generateECDHEShared ctx srvpub case ecdhePair of- Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster@@ -585,15 +618,15 @@ -- 4) process the session parameter to see if the server want to start a new session or can resume -- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher ---onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO)-onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do+onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO)+onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) -- find the compression and cipher methods that the server want to use. cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter) Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter) Just alg -> return alg -- intersect sent extensions in client and the received extensions from server.@@ -635,8 +668,14 @@ Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion) Just _ -> return () if ver > TLS12 then do+ when (serverSession /= clientSession) $+ throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter)+ established <- ctxEstablished ctx+ eof <- ctxEOF ctx+ when (established == Established && not eof) $+ throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion) ensureNullCompression compression- usingHState ctx $ setHelloParameters13 cipherAlg+ failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg return RecvStateDone else do usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg@@ -647,10 +686,12 @@ usingHState ctx $ setMasterSecret rver ClientRole masterSecret logKey ctx (MasterSecret masterSecret) return $ RecvStateNext expectChangeCipher-onServerHello _ _ _ p = unexpected (show p) (Just "server hello")+onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello") processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do+ when (isNullCertificateChain certs) $+ throwCore $ Error_Protocol ("server certificate missing", True, DecodeError) -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation@@ -777,59 +818,34 @@ , KeyUsage_keyAgreement ] -handshakeClient13 :: ClientParams -> Context -> IO ()-handshakeClient13 _cparams ctx = do+handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()+handshakeClient13 cparams ctx groupSent = do usedCipher <- usingHState ctx getPendingCipher let usedHash = cipherHash usedCipher- handshakeClient13' _cparams ctx usedCipher usedHash+ handshakeClient13' cparams ctx groupSent usedCipher usedHash -handshakeClient13' :: ClientParams -> Context -> Cipher -> Hash -> IO ()-handshakeClient13' cparams ctx usedCipher usedHash = do+handshakeClient13' :: ClientParams -> Context -> Maybe Group -> Cipher -> Hash -> IO ()+handshakeClient13' cparams ctx groupSent usedCipher usedHash = do (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret rtt0accepted <- runRecvHandshake13 $ do- accepted <- recvHandshake13preUpdate ctx expectEncryptedExtensions- unless resuming $ recvHandshake13preUpdate ctx expectCertRequest- recvFinished serverHandshakeTrafficSecret+ accepted <- recvHandshake13 ctx expectEncryptedExtensions+ unless resuming $ recvHandshake13 ctx expectCertRequest+ recvHandshake13hash ctx $ expectFinished serverHandshakeTrafficSecret return accepted hChSf <- transcriptHash ctx+ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret- chain <- clientChain cparams ctx- runPacketFlight ctx $ do- case chain of- Nothing -> return ()- Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc- rawFinished <- makeFinished ctx usedHash clientHandshakeTrafficSecret- loadPacket13 ctx $ Handshake13 [rawFinished]+ sendClientFlight13 cparams ctx usedHash clientHandshakeTrafficSecret masterSecret <- switchToTrafficSecret handshakeSecret hChSf setResumptionSecret masterSecret- setEstablished ctx Established+ handshakeTerminate13 ctx where hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 - sendClientData13 chain (Just token) = do- let (CertificateChain certs) = chain- certExts = replicate (length certs) []- cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx- loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]- case certs of- [] -> return ()- _ -> do- hChSc <- transcriptHash ctx- keyAlg <- getLocalDigitalSignatureAlg ctx- sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs keyAlg- vfy <- makeCertVerify ctx keyAlg sigAlg hChSc- loadPacket13 ctx $ Handshake13 [vfy]- --- sendClientData13 _ _ =- throwCore $ Error_Protocol- ( "missing TLS 1.3 certificate request context token"- , True- , InternalError- )- switchToHandshakeSecret = do+ ensureRecvComplete ctx ecdhe <- calcSharedKey (earlySecret, resuming) <- makeEarlySecret let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe@@ -842,6 +858,7 @@ return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) switchToTrafficSecret handshakeSecret hChSf = do+ ensureRecvComplete ctx let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf@@ -861,7 +878,8 @@ Just _ -> error "calcSharedKey: invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) let grp = keyShareEntryGroup serverKeyShare- checkSupportedGroup ctx grp+ unless (groupSent == Just grp) $+ throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter) usingHState ctx $ setNegotiatedGroup grp usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare @@ -874,6 +892,8 @@ Nothing -> return (hkdfExtract usedHash zero zero, False) Just (PreSharedKeyServerHello 0) -> do+ unless (B.length sec == hashSize) $+ throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter) usingHState ctx $ setTLS13HandshakeMode PreSharedKey return (sec, True) Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)@@ -897,55 +917,8 @@ expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") expectCertRequest (CertRequest13 token exts) = do- let hsextID = extensionID_SignatureAlgorithms- -- caextID = extensionID_SignatureAlgorithmsCert- dNames <- canames- -- The @signature_algorithms@ extension is mandatory.- hsAlgs <- extalgs hsextID unsighash- cTypes <- case hsAlgs of- Just as ->- let validAs = filter isHashSignatureValid13 as- in return $ sigAlgsToCertTypes ctx validAs- Nothing -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )- -- Unused:- -- caAlgs <- extalgs caextID uncertsig- usingHState ctx $ do- setCertReqToken $ Just token- setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)- -- setCertReqSigAlgsCert caAlgs- recvHandshake13preUpdate ctx expectCertAndVerify- where- canames = case extensionLookup- extensionID_CertificateAuthorities exts of- Nothing -> return []- Just ext -> case extensionDecode MsgTCertificateRequest ext of- Just (CertificateAuthorities names) -> return names- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )- extalgs extID decons = case extensionLookup extID exts of- Nothing -> return Nothing- Just ext -> case extensionDecode MsgTCertificateRequest ext of- Just e- -> return $ decons e- _ -> throwCore $ Error_Protocol- ( "invalid certificate request"- , True- , HandshakeFailure )-- unsighash :: SignatureAlgorithms- -> Maybe [HashAndSignatureAlgorithm]- unsighash (SignatureAlgorithms a) = Just a-- {- Unused for now- uncertsig :: SignatureAlgorithmsCert- -> Maybe [HashAndSignatureAlgorithm]- uncertsig (SignatureAlgorithmsCert a) = Just a- -}+ processCertRequest13 ctx token exts+ recvHandshake13 ctx expectCertAndVerify expectCertRequest other = do usingHState ctx $ do@@ -954,14 +927,11 @@ -- setCertReqSigAlgsCert Nothing expectCertAndVerify other - expectCertAndVerify (Certificate13 _ cc@(CertificateChain certChain) _) = do+ expectCertAndVerify (Certificate13 _ cc _) = do _ <- liftIO $ processCertificate cparams ctx (Certificates cc)- pubkey <- case certChain of- [] -> throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)- c:_ -> return $ certPubKey $ getCertificate c+ let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc usingHState ctx $ setPublicKey pubkey- hChSc <- transcriptHash ctx- recvHandshake13preUpdate ctx $ expectCertVerify pubkey hChSc+ recvHandshake13hash ctx $ expectCertVerify pubkey expectCertAndVerify p = unexpected (show p) (Just "server certificate") expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do@@ -970,20 +940,95 @@ unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") - recvFinished serverHandshakeTrafficSecret = do- hChSv <- transcriptHash ctx- let verifyData' = makeVerifyData usedHash serverHandshakeTrafficSecret hChSv- recvHandshake13preUpdate ctx $ expectFinished verifyData'-- expectFinished verifyData' (Finished13 verifyData) =- when (verifyData' /= verifyData) $ decryptError "cannot verify finished"- expectFinished _ p = unexpected (show p) (Just "server finished")+ expectFinished baseKey hashValue (Finished13 verifyData) =+ checkFinished usedHash baseKey hashValue verifyData+ expectFinished _ _ p = unexpected (show p) (Just "server finished") setResumptionSecret masterSecret = do hChCf <- transcriptHash ctx let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf usingHState ctx $ setTLS13Secret $ ResuptionSecret resumptionMasterSecret +processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()+processCertRequest13 ctx token exts = do+ let hsextID = extensionID_SignatureAlgorithms+ -- caextID = extensionID_SignatureAlgorithmsCert+ dNames <- canames+ -- The @signature_algorithms@ extension is mandatory.+ hsAlgs <- extalgs hsextID unsighash+ cTypes <- case hsAlgs of+ Just as ->+ let validAs = filter isHashSignatureValid13 as+ in return $ sigAlgsToCertTypes ctx validAs+ Nothing -> throwCore $ Error_Protocol+ ( "invalid certificate request"+ , True+ , HandshakeFailure )+ -- Unused:+ -- caAlgs <- extalgs caextID uncertsig+ usingHState ctx $ do+ setCertReqToken $ Just token+ setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)+ -- setCertReqSigAlgsCert caAlgs+ where+ canames = case extensionLookup+ extensionID_CertificateAuthorities exts of+ Nothing -> return []+ Just ext -> case extensionDecode MsgTCertificateRequest ext of+ Just (CertificateAuthorities names) -> return names+ _ -> throwCore $ Error_Protocol+ ( "invalid certificate request"+ , True+ , HandshakeFailure )+ extalgs extID decons = case extensionLookup extID exts of+ Nothing -> return Nothing+ Just ext -> case extensionDecode MsgTCertificateRequest ext of+ Just e+ -> return $ decons e+ _ -> throwCore $ Error_Protocol+ ( "invalid certificate request"+ , True+ , HandshakeFailure )+ unsighash :: SignatureAlgorithms+ -> Maybe [HashAndSignatureAlgorithm]+ unsighash (SignatureAlgorithms a) = Just a+ {- Unused for now+ uncertsig :: SignatureAlgorithmsCert+ -> Maybe [HashAndSignatureAlgorithm]+ uncertsig (SignatureAlgorithmsCert a) = Just a+ -}++sendClientFlight13 :: ClientParams -> Context -> Hash -> ByteString -> IO ()+sendClientFlight13 cparams ctx usedHash baseKey = do+ chain <- clientChain cparams ctx+ runPacketFlight ctx $ do+ case chain of+ Nothing -> return ()+ Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc+ rawFinished <- makeFinished ctx usedHash baseKey+ loadPacket13 ctx $ Handshake13 [rawFinished]+ where+ sendClientData13 chain (Just token) = do+ let (CertificateChain certs) = chain+ certExts = replicate (length certs) []+ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]+ case certs of+ [] -> return ()+ _ -> do+ hChSc <- transcriptHash ctx+ keyAlg <- getLocalDigitalSignatureAlg ctx+ sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs keyAlg+ vfy <- makeCertVerify ctx keyAlg sigAlg hChSc+ loadPacket13 ctx $ Handshake13 [vfy]+ --+ sendClientData13 _ _ =+ throwCore $ Error_Protocol+ ( "missing TLS 1.3 certificate request context token"+ , True+ , InternalError+ )+ setALPN :: Context -> [ExtensionRaw] -> IO () setALPN ctx exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTServerHello of Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do@@ -994,3 +1039,14 @@ setNegotiatedProtocol proto _ -> return () _ -> return ()++postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()+postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ processHandshake13 ctx h+ processCertRequest13 ctx certReqCtx exts+ (usedHash, _, applicationTrafficSecretN) <- getTxState ctx+ sendClientFlight13 cparams ctx usedHash applicationTrafficSecretN++postHandshakeAuthClientWith _ _ _ =+ throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)
Network/TLS/Handshake/Common.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed- , errorToAlert+ , handleException , unexpected , newSession , handshakeTerminate@@ -14,6 +14,7 @@ , runRecvState , recvPacketHandshake , onRecvStateHandshake+ , ensureRecvComplete , extensionLookup , getSessionData , storePrivInfo@@ -21,6 +22,7 @@ , checkSupportedGroup ) where +import qualified Data.ByteString as B import Control.Concurrent.MVar import Network.TLS.Parameters@@ -28,6 +30,7 @@ import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.IO import Network.TLS.State import Network.TLS.Handshake.Process@@ -42,14 +45,31 @@ import Network.TLS.Imports import Control.Monad.State.Strict-import Control.Exception (throwIO)+import Control.Exception (IOException, handle, fromException, throwIO) handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err +handleException :: Context -> IO () -> IO ()+handleException ctx f = catchException f $ \exception -> do+ let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception+ setEstablished ctx NotEstablished+ handle ignoreIOErr $ do+ tls13 <- tls13orLater ctx+ if tls13 then+ sendPacket13 ctx $ Alert13 $ errorToAlert tlserror+ else+ sendPacket ctx $ Alert $ errorToAlert tlserror+ handshakeFailed tlserror+ where+ ignoreIOErr :: IOException -> IO ()+ ignoreIOErr _ = return ()+ errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)]-errorToAlert (Error_Protocol (_, _, ad)) = [(AlertLevel_Fatal, ad)]-errorToAlert _ = [(AlertLevel_Fatal, InternalError)]+errorToAlert (Error_Protocol (_, _, ad)) = [(AlertLevel_Fatal, ad)]+errorToAlert (Error_Packet_unexpected _ _) = [(AlertLevel_Fatal, UnexpectedMessage)]+errorToAlert (Error_Packet_Parsing _) = [(AlertLevel_Fatal, DecodeError)]+errorToAlert _ = [(AlertLevel_Fatal, InternalError)] unexpected :: MonadIO m => String -> Maybe String -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)@@ -67,7 +87,8 @@ case session of Session (Just sessionId) -> do sessionData <- getSessionData ctx- liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId (fromJust "session-data" sessionData)+ let !sessionId' = B.copy sessionId+ liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' (fromJust "session-data" sessionData) _ -> return () -- forget most handshake data and reset bytes counters. liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake ->@@ -119,8 +140,8 @@ EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvPacketHandshake ctx- _ -> fail ("unexpected type received. expecting handshake and got: " ++ show x)- Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x)+ _ -> unexpected (show x) (Just "handshake")+ Right x -> unexpected (show x) (Just "handshake") Left err -> throwCore err -- | process a list of handshakes message in the recv state machine.@@ -137,6 +158,12 @@ runRecvState _ RecvStateDone = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx++ensureRecvComplete :: MonadIO m => Context -> m ()+ensureRecvComplete ctx = do+ complete <- liftIO $ isRecvComplete ctx+ unless complete $+ throwCore $ Error_Protocol ("received incomplete message at key change", True, UnexpectedMessage) getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do
Network/TLS/Handshake/Common13.hs view
@@ -9,7 +9,7 @@ -- module Network.TLS.Handshake.Common13 ( makeFinished- , makeVerifyData+ , checkFinished , makeServerKeyShare , makeClientKeyShare , fromServerKeyShare@@ -17,6 +17,9 @@ , checkCertVerify , makePSKBinder , replacePSKBinder+ , sendChangeCipherSpec13+ , handshakeTerminate13+ , makeCertRequest , createTLS13TicketInfo , ageToObfuscatedAge , isAgeValid@@ -29,8 +32,8 @@ , safeNonNegative32 , RecvHandshake13M , runRecvHandshake13- , recvHandshake13preUpdate- , recvHandshake13postUpdate+ , recvHandshake13+ , recvHandshake13hash ) where import qualified Data.ByteArray as BA@@ -42,6 +45,7 @@ import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES import Network.TLS.Extension+import Network.TLS.Handshake.Certificate (extractCAname) import Network.TLS.Handshake.Process (processHandshake13) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key@@ -51,6 +55,7 @@ import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC+import Network.TLS.Parameters import Network.TLS.IO import Network.TLS.State import Network.TLS.Struct@@ -59,6 +64,7 @@ import Network.TLS.Wire import Time.System +import Control.Concurrent.MVar import Control.Monad.State.Strict ----------------------------------------------------------------@@ -67,8 +73,13 @@ makeFinished ctx usedHash baseKey = Finished13 . makeVerifyData usedHash baseKey <$> transcriptHash ctx +checkFinished :: MonadIO m => Hash -> ByteString -> ByteString -> ByteString -> m ()+checkFinished usedHash baseKey hashValue verifyData = do+ let verifyData' = makeVerifyData usedHash baseKey hashValue+ unless (verifyData' == verifyData) $ decryptError "cannot verify finished"+ makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString-makeVerifyData usedHash baseKey hashValue = hmac usedHash finishedKey hashValue+makeVerifyData usedHash baseKey = hmac usedHash finishedKey where hashSize = hashDigestSize usedHash finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize@@ -77,18 +88,18 @@ makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of- Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure)+ Left e -> throwCore $ Error_Protocol (show e, True, IllegalParameter) Right cpub -> do ecdhePair <- generateECDHEShared ctx cpub case ecdhePair of- Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, IllegalParameter) Just (spub, share) -> let wspub = IES.encodeGroupPublic spub serverKeyShare = KeyShareEntry grp wspub in return (BA.convert share, serverKeyShare) where ecpub = IES.decodeGroupPublic grp wcpub- msgInvalidPublic = "invalid server " ++ show grp ++ " public key"+ msgInvalidPublic = "invalid client " ++ show grp ++ " public key" makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry) makeClientKeyShare ctx grp = do@@ -99,10 +110,10 @@ fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of- Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure)+ Left e -> throwCore $ Error_Protocol (show e, True, IllegalParameter) Right spub -> case IES.groupGetShared spub cpri of Just shared -> return $ BA.convert shared- Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on (EC)DH", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on (EC)DH", True, IllegalParameter) where espub = IES.decodeGroupPublic grp wspub @@ -172,6 +183,59 @@ ---------------------------------------------------------------- +sendChangeCipherSpec13 :: Context -> PacketFlightM ()+sendChangeCipherSpec13 ctx = do+ sent <- usingHState ctx $ do+ b <- getCCS13Sent+ unless b $ setCCS13Sent True+ return b+ unless sent $ loadPacket13 ctx ChangeCipherSpec13++----------------------------------------------------------------++-- | TLS13 handshake wrap up & clean up. Contrary to @handshakeTerminate@, 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.+handshakeTerminate13 :: Context -> IO ()+handshakeTerminate13 ctx = do+ -- forget most handshake data+ liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake ->+ case mhshake of+ Nothing -> return Nothing+ Just hshake ->+ return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMasterSecret = hstMasterSecret hshake+ , hstNegotiatedGroup = hstNegotiatedGroup hshake+ , hstHandshakeDigest = hstHandshakeDigest hshake+ , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake+ , hstTLS13RTT0Status = hstTLS13RTT0Status hshake+ , hstTLS13Secret = hstTLS13Secret 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 -> Handshake13+makeCertRequest sparams ctx certReqCtx =+ let sigAlgs = extensionEncode $ SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx+ caDns = map extractCAname $ serverCACertificates sparams+ caDnsEncoded = extensionEncode $ CertificateAuthorities caDns+ caExtension+ | null caDns = []+ | otherwise = [ExtensionRaw extensionID_CertificateAuthorities caDnsEncoded]+ crexts = ExtensionRaw extensionID_SignatureAlgorithms sigAlgs : caExtension+ in CertRequest13 certReqCtx crexts++----------------------------------------------------------------+ createTLS13TicketInfo :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo createTLS13TicketInfo life ecw mrtt = do -- Left: serverSendTime@@ -272,24 +336,19 @@ newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a) deriving (Functor, Applicative, Monad, MonadIO) -recvHandshake13preUpdate :: MonadIO m- => Context- -> (Handshake13 -> RecvHandshake13M m a)- -> RecvHandshake13M m a-recvHandshake13preUpdate ctx f = do- h <- getHandshake13 ctx- liftIO $ processHandshake13 ctx h- f h+recvHandshake13 :: MonadIO m+ => Context+ -> (Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+recvHandshake13 ctx f = getHandshake13 ctx >>= f -recvHandshake13postUpdate :: MonadIO m- => Context- -> (Handshake13 -> RecvHandshake13M m a)- -> RecvHandshake13M m a-recvHandshake13postUpdate ctx f = do- h <- getHandshake13 ctx- v <- f h- liftIO $ processHandshake13 ctx h- return v+recvHandshake13hash :: MonadIO m+ => Context+ -> (ByteString -> Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+recvHandshake13hash ctx f = do+ d <- transcriptHash ctx+ getHandshake13 ctx >>= f d getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13 getHandshake13 ctx = RecvHandshake13M $ do@@ -298,11 +357,11 @@ (h:hs) -> found h hs [] -> recvLoop where- found h hs = put hs >> return h+ found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h recvLoop = do epkt <- recvPacket13 ctx case epkt of- Right (Handshake13 []) -> recvLoop+ Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h:hs)) -> found h hs Right ChangeCipherSpec13 -> recvLoop Right x -> unexpected (show x) (Just "handshake 13")
Network/TLS/Handshake/Process.hs view
@@ -111,7 +111,7 @@ serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams unless (dhValid params $ dhUnwrapPublic clientDHValue) $- throwCore $ Error_Protocol ("invalid client public key", True, HandshakeFailure)+ throwCore $ Error_Protocol ("invalid client public key", True, IllegalParameter) dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared params dhpriv clientDHValue@@ -121,7 +121,7 @@ processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams case decodeGroupPublic grp bytes of- Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, HandshakeFailure)+ Left _ -> throwCore $ Error_Protocol ("client public key cannot be decoded", True, IllegalParameter) Right clipub -> do srvpri <- usingHState ctx getGroupPrivate case groupGetShared clipub srvpri of@@ -130,7 +130,7 @@ role <- usingState_ ctx isClientContext masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret)- Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, IllegalParameter) processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do
Network/TLS/Handshake/Random.hs view
@@ -59,11 +59,8 @@ suffix11 :: B.ByteString suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00] --- ClientRandom in the second client hello for retry must be--- the same as the first one.-clientRandom :: Context -> Maybe ClientRandom -> IO ClientRandom-clientRandom ctx Nothing = ClientRandom <$> getStateRNG ctx 32-clientRandom _ (Just cr) = return cr+clientRandom :: Context -> IO ClientRandom+clientRandom ctx = ClientRandom <$> getStateRNG ctx 32 hrrRandom :: ServerRandom hrrRandom = ServerRandom $ B.pack [
Network/TLS/Handshake/Server.hs view
@@ -9,6 +9,8 @@ module Network.TLS.Handshake.Server ( handshakeServer , handshakeServerWith+ , requestCertificateServer+ , postHandshakeAuthServerWith ) where import Network.TLS.Parameters@@ -35,6 +37,7 @@ import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict+import Control.Exception (bracket) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Common@@ -50,12 +53,12 @@ -- -- This is just a helper to pop the next message from the recv layer, -- and call handshakeServerWith.-handshakeServer :: MonadIO m => ServerParams -> Context -> m ()+handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do hss <- recvPacketHandshake ctx case hss of [ch] -> handshakeServerWith sparams ctx ch- _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)+ _ -> unexpected (show hss) (Just "client hello") -- | Put the server context in handshake mode. --@@ -82,17 +85,17 @@ -- -> finish <- finish -- handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()-handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ clientSession ciphers compressions exts _) = do+handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientSession ciphers compressions exts _) = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do ver <- usingState_ ctx (getVersionWithDefault TLS10)- when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", False, NoRenegotiation)+ when (ver == TLS13) $ throwCore $ Error_Protocol ("renegotiation is not allowed in TLS 1.3", True, UnexpectedMessage) -- rejecting client initiated renegotiation to prevent DOS.- unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do- eof <- ctxEOF ctx- when (established == Established && not eof) $- throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation)+ eof <- ctxEOF ctx+ let renegotiation = established == Established && not eof+ when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $+ throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation) -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")@@ -102,26 +105,29 @@ processHandshake ctx clientHello -- rejecting SSL2. RFC 6176- when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion)+ when (legacyVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion) -- rejecting SSL3. RFC 7568- -- when (clientVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion)+ -- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion) -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) &&- clientVersion < TLS12) $+ legacyVersion < TLS12) $ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback) -- choosing TLS version let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of Just (SupportedVersionsClientHello vers) -> vers _ -> []- serverVersions = supportedVersions $ ctxSupported ctx+ clientVersion = min TLS12 legacyVersion+ serverVersions+ | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx)+ | otherwise = supportedVersions $ ctxSupported ctx mVersion = debugVersionForced $ serverDebug sparams chosenVersion <- case mVersion of Just cver -> return cver Nothing ->- if (TLS13 `elem` serverVersions) && clientVersion == TLS12 && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of+ if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion) Just v -> return v else case findHighestVersionFrom clientVersion serverVersions of@@ -403,9 +409,6 @@ -- Send HelloDone sendPacket ctx (Handshake [ServerHelloDone]) - extractCAname :: SignedCertificate -> DistinguishedName- extractCAname cert = certSubjectDN $ getCertificate cert- setup_DHE = do let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups (dhparams, priv, pub) <-@@ -646,6 +649,8 @@ -> Session -> IO () handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts clientCiphers _serverName clientSession = do+ when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $+ throwCore $ Error_Protocol ("extension pre_shared_key must be last", True, IllegalParameter) -- Deciding cipher. -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle@@ -684,7 +689,9 @@ -> Session -> Bool -> IO () doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do- newSession ctx >>= \ss -> usingState_ ctx (setSession ss False)+ newSession ctx >>= \ss -> usingState_ ctx $ do+ setSession ss False+ setClientSupportsPHA supportsPHA usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter (psk, binderInfo, is0RTTvalid) <- choosePSK@@ -713,9 +720,11 @@ return () mCredInfo <- if authenticated then return Nothing else decideCredentialInfo (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare+ ensureRecvComplete ctx let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe clientHandshakeTrafficSecret <- runPacketFlight ctx $ do sendServerHello keyShare srand extensions+ sendChangeCipherSpec13 ctx ---------------------------------------------------------------- hChSh <- transcriptHash ctx let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh@@ -726,7 +735,6 @@ setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlyTrafficSecret else clientHandshakeTrafficSecret setTxState ctx usedHash usedCipher serverHandshakeTrafficSecret ----------------------------------------------------------------- loadPacket13 ctx ChangeCipherSpec13 sendExtensions rtt0OK case mCredInfo of Nothing -> return ()@@ -752,57 +760,63 @@ else when (established == NotEstablished) $ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding - let expectFinished (Finished13 verifyData') = do- hChBeforeCf <- transcriptHash ctx- let verifyData = makeVerifyData usedHash clientHandshakeTrafficSecret hChBeforeCf- if verifyData == verifyData' then liftIO $ do- setEstablished ctx Established- setRxState ctx usedHash usedCipher clientApplicationTrafficSecret0- else- decryptError "cannot verify finished"- expectFinished hs = unexpected (show hs) (Just "finished 13")+ let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do+ checkFinished usedHash clientHandshakeTrafficSecret hChBeforeCf verifyData+ handshakeTerminate13 ctx+ setRxState ctx usedHash usedCipher clientApplicationTrafficSecret0+ sendNewSessionTicket masterSecret sfSentTime+ expectFinished _ hs = unexpected (show hs) (Just "finished 13") let expectEndOfEarlyData EndOfEarlyData13 = setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data")- let sendNST = sendNewSessionTicket masterSecret sfSentTime if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do- skip <- recvHandshake13postUpdate ctx expectCertificate- unless skip $ recvHandshake13postUpdate ctx expectCertVerify- recvHandshake13postUpdate ctx expectFinished- liftIO sendNST+ skip <- recvHandshake13 ctx expectCertificate+ unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)+ recvHandshake13hash ctx expectFinished+ ensureRecvComplete ctx else if rtt0OK then- setPendingActions ctx [(expectEndOfEarlyData, return ())- ,(expectFinished, sendNST)]- else do- setPendingActions ctx [(expectFinished, sendNST)]+ setPendingActions ctx [PendingAction True expectEndOfEarlyData+ ,PendingActionHash True expectFinished]+ else+ runRecvHandshake13 $ do+ recvHandshake13hash ctx expectFinished+ ensureRecvComplete ctx where setServerParameter = do srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion chosenVersion- usingHState ctx $ setHelloParameters13 usedCipher+ failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher return srand + supportsPHA = case extensionLookup extensionID_PostHandshakeAuth exts >>= extensionDecode MsgTClientHello of+ Just PostHandshakeAuth -> True+ Nothing -> False+ choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do- let len = sum (map (\x -> B.length x + 1) bnds) + 2- mgr = sharedSessionManager $ serverShared sparams- msdata <- if rtt0 then sessionResumeOnlyOnce mgr sessionId- else sessionResume mgr sessionId- case msdata of- Just sdata -> do- let Just tinfo = 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)+ when (null dhModes) $+ throwCore $ Error_Protocol ("no psk_key_exchange_modes extension", True, MissingExtension)+ if PSK_DHE_KE `elem` dhModes then do+ let len = sum (map (\x -> B.length x + 1) bnds) + 2+ mgr = sharedSessionManager $ serverShared sparams+ msdata <- if rtt0 then sessionResumeOnlyOnce mgr sessionId+ else sessionResume mgr sessionId+ case msdata of+ Just sdata -> do+ let Just tinfo = 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) _ -> return (zero, Nothing, False) checkSessionEquality sdata = do@@ -862,9 +876,8 @@ storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here.- let sigAlgs = extensionEncode $ SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx- crexts = [ExtensionRaw extensionID_SignatureAlgorithms sigAlgs]- loadPacket13 ctx $ Handshake13 [CertRequest13 certReqCtx crexts]+ certReq = makeCertRequest sparams ctx certReqCtx+ loadPacket13 ctx $ Handshake13 [certReq] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain@@ -876,18 +889,25 @@ loadPacket13 ctx $ Handshake13 [vrfy] sendExtensions rtt0OK = do- extensions' <- liftIO $ applicationProtocol ctx exts sparams+ protoExt <- liftIO $ applicationProtocol ctx exts sparams msni <- liftIO $ usingState_ ctx getClientSNI- let extensions'' = case msni of+ let sniExtension = case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty.- Just _ -> ExtensionRaw extensionID_ServerName "" : extensions'- Nothing -> extensions'- let extensions- | rtt0OK = ExtensionRaw extensionID_EarlyData (extensionEncode (EarlyDataIndication Nothing)) : extensions''- | otherwise = extensions''+ Just _ -> Just $ ExtensionRaw extensionID_ServerName ""+ Nothing -> Nothing+ mgroup <- usingHState ctx getNegotiatedGroup+ let serverGroups = supportedGroups (ctxSupported ctx)+ groupExtension+ | null serverGroups = Nothing+ | maybe True (== head serverGroups) mgroup = Nothing+ | otherwise = Just $ ExtensionRaw extensionID_NegotiatedGroups $ extensionEncode (NegotiatedGroups serverGroups)+ let earlyDataExtension+ | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing)+ | otherwise = Nothing+ let extensions = catMaybes [earlyDataExtension, groupExtension, sniExtension] ++ protoExt loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions] sendNewSessionTicket masterSecret sfSentTime = when sendNST $ do@@ -896,16 +916,13 @@ hChCf <- transcriptHash ctx nonce <- getStateRNG ctx 32 let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf- life = 86400 -- 1 day in second: fixme hard coding+ life = toSeconds $ serverTicketLifetime sparams psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize (label, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce label rtt0max sendPacket13 ctx $ Handshake13 [nst] where- sendNST = (PSK_KE `elem` dhModes) || (PSK_DHE_KE `elem` dhModes)- dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of- Just (PskKeyExchangeModes ms) -> ms- Nothing -> []+ sendNST = PSK_DHE_KE `elem` dhModes generateSession life psk maxSize rtt = do Session (Just sessionId) <- newSession ctx tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt)@@ -918,7 +935,14 @@ where tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize extensions = [ExtensionRaw extensionID_EarlyData tedi]+ toSeconds i | i < 0 = 0+ | i > 604800 = 604800+ | otherwise = fromIntegral i + dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of+ Just (PskKeyExchangeModes ms) -> ms+ Nothing -> []+ expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter)@@ -927,29 +951,28 @@ return $ isNullCertificateChain certs expectCertificate hs = unexpected (show hs) (Just "certificate 13") - expectCertVerify :: Handshake13 -> RecvHandshake13M IO ()- expectCertVerify (CertVerify13 sigAlg sig) = liftIO $ do- hChCc <- transcriptHash ctx- certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected"- pubkey <- case cc of- [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)- c:_ -> return $ certPubKey $ getCertificate c- usingHState ctx $ setPublicKey pubkey- let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)- verif <- checkCertVerify ctx keyAlg sigAlg sig hChCc- clientCertVerify sparams ctx certs verif- expectCertVerify hs = unexpected (show hs) (Just "certificate verify 13")- hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 +expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()+expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do+ certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected"+ pubkey <- case cc of+ [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)+ c:_ -> return $ certPubKey $ getCertificate c+ usingHState ctx $ setPublicKey pubkey+ let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)+ verif <- checkCertVerify ctx keyAlg sigAlg sig hChCc+ clientCertVerify sparams ctx certs verif+expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13")+ helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m () helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure) usingState_ ctx $ setTLS13HRR True- usingHState ctx $ setHelloParameters13 usedCipher+ failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups gs) -> gs Nothing -> []@@ -963,7 +986,9 @@ ,ExtensionRaw extensionID_SupportedVersions selectedVersion] hrr = ServerHello13 hrrRandom clientSession (cipherID usedCipher) extensions usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- sendPacket13 ctx $ Handshake13 [hrr]+ runPacketFlight ctx $ do+ loadPacket13 ctx $ Handshake13 [hrr]+ sendChangeCipherSpec13 ctx handshakeServer sparams ctx findHighestVersionFrom :: Version -> [Version] -> Maybe Version@@ -1083,3 +1108,51 @@ -- chain to the context. usingState_ ctx $ setClientCertificateChain certs else decryptError "verification failed"++newCertReqContext :: Context -> IO CertReqContext+newCertReqContext ctx = getStateRNG ctx 32++requestCertificateServer :: ServerParams -> Context -> IO Bool+requestCertificateServer sparams ctx = do+ tls13 <- tls13orLater ctx+ supportsPHA <- usingState_ ctx getClientSupportsPHA+ let ok = tls13 && supportsPHA+ when ok $ do+ certReqCtx <- newCertReqContext ctx+ let certReq = makeCertRequest sparams ctx certReqCtx+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ addCertRequest13 ctx certReq+ sendPacket13 ctx $ Handshake13 [certReq]+ return ok++postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()+postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do+ mCertReq <- getCertRequest13 ctx certCtx+ when (isNothing mCertReq) $ throwCore $ Error_Protocol ("unknown certificate request context", True, DecodeError)+ let certReq = fromJust "certReq" mCertReq++ -- fixme checking _ext+ clientCertificate sparams ctx certs++ baseHState <- saveHState ctx+ processHandshake13 ctx certReq+ processHandshake13 ctx h++ (usedHash, _, applicationTrafficSecretN) <- getRxState ctx++ let expectFinished hChBeforeCf (Finished13 verifyData) = do+ checkFinished usedHash applicationTrafficSecretN hChBeforeCf verifyData+ void $ restoreHState ctx baseHState+ expectFinished _ hs = unexpected (show hs) (Just "finished 13")++ -- Note: here the server could send updated NST too, however the library+ -- currently has no API to handle resumption and client authentication+ -- together, see discussion in #133+ if isNullCertificateChain certs+ then setPendingActions ctx [ PendingActionHash False expectFinished ]+ else setPendingActions ctx [ PendingActionHash False (expectCertVerify sparams ctx)+ , PendingActionHash False expectFinished+ ]++postHandshakeAuthServerWith _ _ _ =+ throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthServerWith", True, UnexpectedMessage)
Network/TLS/Handshake/State.hs view
@@ -66,6 +66,8 @@ , getTLS13RTT0Status , setTLS13Secret , getTLS13Secret+ , setCCS13Sent+ , getCCS13Sent ) where import Network.TLS.Util@@ -119,7 +121,8 @@ , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent , hstCertReqSent :: !Bool- -- ^ Set to true when a certificate request was sent+ -- ^ Set to true when a certificate request was sent. This applies+ -- only to requests sent during handshake (not post-handshake). , hstClientCertChain :: !(Maybe CertificateChain) , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState@@ -129,6 +132,7 @@ , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: !RTT0Status , hstTLS13Secret :: Secret13+ , hstCCS13Sent :: !Bool } deriving (Show) {- | When we receive a CertificateRequest from a server, a just-in-time@@ -217,6 +221,7 @@ , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None , hstTLS13Secret = NoSecret+ , hstCCS13Sent = False } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState)@@ -301,6 +306,12 @@ getTLS13Secret :: HandshakeM Secret13 getTLS13Secret = gets hstTLS13Secret++setCCS13Sent :: Bool -> HandshakeM ()+setCCS13Sent sent = modify (\hst -> hst { hstCCS13Sent = sent })++getCCS13Sent :: HandshakeM Bool+getCCS13Sent = gets hstCCS13Sent setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b })
Network/TLS/Handshake/State13.hs view
@@ -17,6 +17,7 @@ , setHelloParameters13 , transcriptHash , wrapAsMessageHash13+ , PendingAction(..) , setPendingActions , popPendingAction ) where@@ -32,6 +33,7 @@ import Network.TLS.Handshake.State import Network.TLS.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State+import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Util @@ -90,18 +92,21 @@ clearXState func ctx = modifyMVar_ (func ctx) (\rt -> return rt { stCipher = Nothing }) -setHelloParameters13 :: Cipher -> HandshakeM ()-setHelloParameters13 cipher = modify update- where- update hst = case hstPendingCipher hst of- Nothing -> hst {+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 }- Just oldcipher -> if cipher == oldcipher- then hst- else error "TLS 1.3: cipher changed"+ return $ Right ()+ Just oldcipher+ | cipher == oldcipher -> return $ Right ()+ | otherwise -> return $ Left $ Error_Protocol ("TLS 1.3 cipher changed after hello retry", True, IllegalParameter)+ where hashAlg = cipherHash cipher updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"
Network/TLS/Hooks.hs view
@@ -12,7 +12,8 @@ ) where import qualified Data.ByteString as B-import Network.TLS.Struct (Header, Handshake(..))+import Network.TLS.Struct (Header, Handshake)+import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain) import Data.Default.Class @@ -41,6 +42,8 @@ data Hooks = Hooks { -- | called at each handshake message received hookRecvHandshake :: Handshake -> IO Handshake+ -- | called at each handshake message received for TLS 1.3+ , hookRecvHandshake13 :: Handshake13 -> IO Handshake13 -- | called at each certificate chain message received , hookRecvCertificates :: CertificateChain -> IO () -- | hooks on IO and packets, receiving and sending.@@ -50,6 +53,7 @@ defaultHooks :: Hooks defaultHooks = Hooks { hookRecvHandshake = return+ , hookRecvHandshake13 = return , hookRecvCertificates = return . const () , hookLogging = def }
Network/TLS/IO.hs view
@@ -13,6 +13,7 @@ , sendPacket13 , recvPacket , recvPacket13+ , isRecvComplete -- * Grouping multiple packets in the same flight , PacketFlightM , runPacketFlight@@ -20,11 +21,10 @@ ) where import Network.TLS.Context.Internal+import Network.TLS.ErrT import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Record-import Network.TLS.Record.Types13-import Network.TLS.Record.Disengage13 import Network.TLS.Packet import Network.TLS.Hooks import Network.TLS.Sending@@ -37,6 +37,7 @@ import Data.IORef import Control.Monad.Reader+import Control.Monad.State.Strict import Control.Exception (finally, throwIO) import System.IO.Error (mkIOError, eofErrorType) @@ -59,14 +60,31 @@ then Error_EOF else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) +getRecord :: Context -> Int -> Header -> ByteString -> IO (Either TLSError (Record Plaintext))+getRecord ctx appDataOverhead header@(Header pt _ _) content = do+ withLog ctx $ \logging -> loggingIORecv logging header content+ runRxState ctx $ do+ r <- disengageRecord $ rawToRecord header (fragmentCiphertext content)+ let Record _ _ fragment = r+ when (B.length (fragmentGetBytes fragment) > 16384 + overhead) $+ throwError contentSizeExceeded+ return r+ where overhead = if pt == ProtocolType_AppData then appDataOverhead else 0 +contentSizeExceeded :: TLSError+contentSizeExceeded = Error_Protocol ("record content exceeding maximum size", True, RecordOverflow)++maximumSizeExceeded :: TLSError+maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)+ -- | recvRecord receive a full TLS record (header + data), from the other side. -- -- The record is disengaged from the record layer recvRecord :: Bool -- ^ flag to enable SSLv2 compat ClientHello reception+ -> Int -- ^ number of AppData bytes to accept above normal maximum size -> Context -- ^ TLS context -> IO (Either TLSError (Record Plaintext))-recvRecord compatSSLv2 ctx+recvRecord compatSSLv2 appDataOverhead ctx #ifdef SSLV2_COMPATIBLE | compatSSLv2 = readExact ctx 2 >>= either (return . Left) sslv2Header #endif@@ -78,7 +96,7 @@ | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded | otherwise = readExact ctx (fromIntegral readlen) >>=- either (return . Left) (getRecord header)+ either (return . Left) (getRecord ctx appDataOverhead header) #ifdef SSLV2_COMPATIBLE sslv2Header header = if B.head header >= 0x80@@ -93,13 +111,9 @@ case res of Left e -> return $ Left e Right content ->- either (return . Left) (`getRecord` content) $ decodeDeprecatedHeader readlen content+ let hdr = decodeDeprecatedHeader readlen (B.take 3 content)+ in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr #endif- maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)- getRecord :: Header -> ByteString -> IO (Either TLSError (Record Plaintext))- getRecord header content = do- withLog ctx $ \logging -> loggingIORecv logging header content- runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True@@ -111,43 +125,61 @@ recvPacket :: MonadIO m => Context -> m (Either TLSError Packet) recvPacket ctx = liftIO $ do compatSSLv2 <- ctxHasSSLv2ClientHello ctx- erecord <- recvRecord compatSSLv2 ctx+ hrr <- usingState_ ctx getTLS13HRR+ -- When a client sends 0-RTT data to a server which rejects and sends a HRR,+ -- the server will not decrypt AppData segments. The server needs to accept+ -- AppData with maximum size 2^14 + 256. In all other scenarios and record+ -- types the maximum size is 2^14.+ let appDataOverhead = if hrr then 256 else 0+ erecord <- recvRecord compatSSLv2 appDataOverhead ctx case erecord of Left err -> return $ Left err- Right record -> do- hrr <- usingState_ ctx getTLS13HRR+ Right record -> if hrr && isCCS record then recvPacket ctx else do pktRecv <- processPacket ctx record- pkt <- case pktRecv of- Right (Handshake hss) ->- ctxWithHooks ctx $ \hooks ->- Right . Handshake <$> mapM (hookRecvHandshake hooks) hss- _ -> return pktRecv- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx- return pkt+ if isEmptyHandshake pktRecv then+ -- When a handshake record is fragmented we continue+ -- receiving in order to feed stHandshakeRecordCont+ recvPacket ctx+ else do+ pkt <- case pktRecv of+ Right (Handshake hss) ->+ ctxWithHooks ctx $ \hooks ->+ Right . Handshake <$> mapM (hookRecvHandshake hooks) hss+ _ -> return pktRecv+ case pkt of+ Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p+ _ -> return ()+ when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx+ return pkt +isEmptyHandshake :: Either TLSError Packet -> Bool+isEmptyHandshake (Right (Handshake [])) = True+isEmptyHandshake _ = False+ -- | Send one packet to the context sendPacket :: MonadIO m => Context -> Packet -> m () sendPacket ctx 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.- withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx- when (isNonNullAppData pkt && withEmptyPacket) $ sendPacket ctx $ AppData B.empty+ when (isNonNullAppData pkt) $ do+ withEmptyPacket <- liftIO $ readIORef $ ctxNeedEmptyPacket ctx+ when withEmptyPacket $+ writePacketBytes ctx (AppData B.empty) >>= sendBytes ctx + writePacketBytes ctx pkt >>= sendBytes ctx+ where isNonNullAppData (AppData b) = not $ B.null b+ isNonNullAppData _ = False++writePacketBytes :: MonadIO m => Context -> Packet -> m ByteString+writePacketBytes ctx pkt = do edataToSend <- liftIO $ do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) writePacket ctx pkt- case edataToSend of- Left err -> throwCore err- Right dataToSend -> sendBytes ctx dataToSend- where isNonNullAppData (AppData b) = not $ B.null b- isNonNullAppData _ = False+ either throwCore return edataToSend sendPacket13 :: MonadIO m => Context -> Packet13 -> m () sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx@@ -165,19 +197,14 @@ contextSend ctx dataToSend recvRecord13 :: Context- -> IO (Either TLSError Record13)+ -> IO (Either TLSError (Record Plaintext)) recvRecord13 ctx = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) where recvLengthE = either (return . Left) recvLength recvLength header@(Header _ _ readlen)- | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded+ | readlen > 16384 + 256 = return $ Left maximumSizeExceeded | otherwise = readExact ctx (fromIntegral readlen) >>=- either (return . Left) (getRecord header)- maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)- getRecord :: Header -> ByteString -> IO (Either TLSError Record13)- getRecord header content = do- liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content- runRxState ctx $ disengageRecord13 $ rawToRecord13 header content+ either (return . Left) (getRecord ctx 0 header) recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13) recvPacket13 ctx = liftIO $ do@@ -194,11 +221,31 @@ _ -> return $ Left err Left err -> return $ Left err Right record -> do- pkt <- processPacket13 ctx record- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- return pkt+ pktRecv <- processPacket13 ctx record+ if isEmptyHandshake13 pktRecv then+ -- When a handshake record is fragmented we continue receiving+ -- in order to feed stHandshakeRecordCont13+ recvPacket13 ctx+ else do+ pkt <- case pktRecv of+ Right (Handshake13 hss) ->+ ctxWithHooks ctx $ \hooks ->+ Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss+ _ -> return pktRecv+ case pkt of+ Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p+ _ -> return ()+ return pkt++isEmptyHandshake13 :: Either TLSError Packet13 -> Bool+isEmptyHandshake13 (Right (Handshake13 [])) = True+isEmptyHandshake13 _ = False++isRecvComplete :: Context -> IO Bool+isRecvComplete ctx = usingState_ ctx $ do+ cont <- gets stHandshakeRecordCont+ cont13 <- gets stHandshakeRecordCont13+ return $! isNothing cont && isNothing cont13 -- | State monad used to group several packets together and send them on wire as -- single flight. When packets are loaded in the monad, they are logged
Network/TLS/Internal.hs view
@@ -8,7 +8,9 @@ -- module Network.TLS.Internal ( module Network.TLS.Struct+ , module Network.TLS.Struct13 , module Network.TLS.Packet+ , module Network.TLS.Packet13 , module Network.TLS.Receiving , module Network.TLS.Sending , module Network.TLS.Wire@@ -17,7 +19,9 @@ ) where import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Packet+import Network.TLS.Packet13 import Network.TLS.Receiving import Network.TLS.Sending import Network.TLS.Wire
Network/TLS/Parameters.hs view
@@ -138,9 +138,13 @@ , serverHooks :: ServerHooks , serverSupported :: Supported , serverDebug :: DebugParams- -- ^ Server accepts this size of early data in TLS 1.3.+ -- | Server accepts this size of early data in TLS 1.3. -- 0 (or lower) means that the server does not accept early data. , serverEarlyDataSize :: Int+ -- | Lifetime in seconds for session tickets generated by the server.+ -- Acceptable value range is 0 to 604800 (7 days). The default lifetime+ -- is 86400 seconds (1 day).+ , serverTicketLifetime :: Int } deriving (Show) defaultParamsServer :: ServerParams@@ -153,6 +157,7 @@ , serverSupported = def , serverDebug = defaultDebugParams , serverEarlyDataSize = 0+ , serverTicketLifetime = 86400 } instance Default ServerParams where@@ -161,9 +166,13 @@ -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported {- -- | 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 chosed.+ -- | 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. supportedVersions :: [Version] -- | Supported cipher methods. The default is empty, specify a suitable -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often
+ Network/TLS/PostHandshake.hs view
@@ -0,0 +1,39 @@+-- |+-- Module : Network.TLS.PostHandshake+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.PostHandshake+ ( requestCertificate+ , requestCertificateServer+ , postHandshakeAuthWith+ , postHandshakeAuthClientWith+ , postHandshakeAuthServerWith+ ) where++import Network.TLS.Context.Internal+import Network.TLS.IO+import Network.TLS.Struct13++import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Client+import Network.TLS.Handshake.Server++import Control.Monad.State.Strict++-- | 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.+requestCertificate :: MonadIO m => Context -> m Bool+requestCertificate ctx =+ liftIO $ withWriteLock ctx $+ checkValid ctx >> ctxDoRequestCertificate 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.+postHandshakeAuthWith :: MonadIO m => Context -> Handshake13 -> m ()+postHandshakeAuthWith ctx hs =+ liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoPostHandshakeAuthWith ctx ctx hs
Network/TLS/Receiving13.hs view
@@ -20,7 +20,7 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.ErrT-import Network.TLS.Record.Types13+import Network.TLS.Record.Types import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Wire@@ -28,14 +28,14 @@ import Network.TLS.Util import Network.TLS.Imports -processPacket13 :: Context -> Record13 -> IO (Either TLSError Packet13)-processPacket13 _ (Record13 ContentType_ChangeCipherSpec _) = return $ Right ChangeCipherSpec13-processPacket13 _ (Record13 ContentType_AppData fragment) = return $ Right $ AppData13 fragment-processPacket13 _ (Record13 ContentType_Alert fragment) = return (Alert13 `fmapEither` decodeAlerts fragment)-processPacket13 ctx (Record13 ContentType_Handshake fragment) = usingState ctx $ do+processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)+processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13+processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment+processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))+processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do mCont <- gets stHandshakeRecordCont13 modify (\st -> st { stHandshakeRecordCont13 = Nothing })- hss <- parseMany mCont fragment+ hss <- parseMany mCont (fragmentGetBytes fragment) return $ Handshake13 hss where parseMany mCont bs = case fromMaybe decodeHandshakeRecord13 mCont bs of@@ -47,3 +47,5 @@ case decodeHandshake13 ty content of Left err -> throwError err Right hh -> (hh:) <$> parseMany Nothing left+processPacket13 _ (Record ProtocolType_DeprecatedHandshake _ _) =+ return (Left $ Error_Packet "deprecated handshake packet 1.3")
Network/TLS/Record/Disengage.hs view
@@ -8,6 +8,10 @@ -- Disengage a record from the Record layer. -- The record is decrypted, checked for integrity and then decompressed. --+-- Starting with TLS v1.3, only the "null" compression method is negotiated in+-- the handshake, so the decompression step will be a no-op. Decryption and+-- integrity verification are performed using an AEAD cipher only.+-- {-# LANGUAGE FlexibleContexts #-} module Network.TLS.Record.Disengage@@ -40,12 +44,43 @@ withCompression $ compressionInflate bytes decryptRecord :: Record Ciphertext -> RecordM (Record Compressed)-decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do+decryptRecord record@(Record ct ver fragment) = do st <- get case stCipher st of- Nothing -> return e- _ -> getRecordVersion >>= \ver -> decryptData ver record e st+ Nothing -> noDecryption+ _ -> do+ recOpts <- getRecordOptions+ let mver = recordVersion recOpts+ if recordTLS13 recOpts+ then decryptData13 mver (fragmentGetBytes fragment) st+ else onRecordFragment record $ fragmentUncipher $ \e ->+ decryptData mver record e st+ where+ noDecryption = onRecordFragment record $ fragmentUncipher return+ decryptData13 mver e st+ | ct == ProtocolType_AppData = do+ inner <- decryptData mver record e st+ case unInnerPlaintext inner of+ Left message -> throwError $ Error_Protocol (message, True, UnexpectedMessage)+ Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)+ | otherwise = noDecryption +unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)+unInnerPlaintext inner =+ case B.unsnoc dc of+ Nothing -> Left $ unknownContentType13 (0 :: Word8)+ Just (bytes,c) ->+ case valToType c of+ Nothing -> Left $ unknownContentType13 c+ Just ct+ | B.null bytes && ct `elem` nonEmptyContentTypes ->+ Left ("empty " ++ show ct ++ " record disallowed")+ | otherwise -> Right (ct, bytes)+ where+ (dc,_pad) = B.spanEnd (== 0) inner+ nonEmptyContentTypes = [ ProtocolType_Handshake, ProtocolType_Alert ]+ unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c+ getCipherData :: Record a -> CipherData -> RecordM ByteString getCipherData (Record pt ver _) cdata = do -- check if the MAC is valid.@@ -133,8 +168,10 @@ iv = cstIV (stCryptState tst) ivlen = B.length iv Header typ v _ = recordToHeader record- hdr = Header typ v $ fromIntegral cipherLen- ad = B.concat [ encodedSeq, encodeHeader hdr ]+ hdrLen = if ver >= TLS13 then econtentLen else cipherLen+ hdr = Header typ v $ fromIntegral hdrLen+ ad | ver >= TLS13 = encodeHeader hdr+ | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce | nonceExpLen == 0 = B.xor iv sqnc | otherwise = iv `B.append` enonce
− Network/TLS/Record/Disengage13.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}---- |--- Module : Network.TLS.Record.Disengage13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Disengage a record from the Record layer.--- The record is decrypted, checked for integrity and then decompressed.----module Network.TLS.Record.Disengage13- ( disengageRecord13- ) where--import Control.Monad.State--import Network.TLS.Imports-import Crypto.Cipher.Types (AuthTag(..))-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.ErrT-import Network.TLS.Record.State-import Network.TLS.Record.Types13-import Network.TLS.Cipher-import Network.TLS.Util-import Network.TLS.Wire-import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert, xor)--disengageRecord13 :: Record13 -> RecordM Record13-disengageRecord13 record@(Record13 ContentType_AppData e) = do- st <- get- case stCipher st of- Nothing -> return record- _ -> do- inner <- decryptData e st- let (dc,_pad) = B.spanEnd (== 0) inner- Just (d,c) = B.unsnoc dc- Just ct = valToType c- return $ Record13 ct d-disengageRecord13 record = return record--decryptData :: ByteString -> RecordState -> RecordM ByteString-decryptData econtent tst = decryptOf (cstKey cst)- where cipher = fromJust "cipher" $ stCipher tst- bulk = cipherBulk cipher- cst = stCryptState tst- econtentLen = B.length econtent-- decryptOf :: BulkState -> RecordM ByteString- decryptOf (BulkStateAEAD decryptF) = do- let authTagLen = bulkAuthTagLen bulk- cipherLen = econtentLen - authTagLen-- (econtent', authTag) <- get2o econtent (cipherLen, authTagLen)- let encodedSeq = encodeWord64 $ msSequence $ stMacState tst- iv = cstIV cst- ivlen = B.length iv- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce = B.xor iv sqnc- additional = "\23\3\3" `B.append` encodeWord16 (fromIntegral econtentLen)- (content, authTag2) = decryptF nonce econtent' additional-- when (AuthTag (B.convert authTag) /= authTag2) $- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)- modify incrRecordState- return content-- decryptOf _ =- throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError)-- -- handling of outer format can report errors with Error_Packet- get3o s ls = maybe (throwError $ Error_Packet "record bad format 1.3") return $ partition3 s ls- get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
Network/TLS/Record/Engage.hs view
@@ -8,6 +8,10 @@ -- Engage a record into the Record layer. -- The record is compressed, added some integrity field, then encrypted. --+-- Starting with TLS v1.3, only the "null" compression method is negotiated in+-- the handshake, so the compression step will be a no-op. Integrity and+-- encryption are performed using an AEAD cipher only.+-- {-# LANGUAGE BangPatterns #-} module Network.TLS.Record.Engage ( engageRecord@@ -23,6 +27,7 @@ import Network.TLS.Compression import Network.TLS.Wire import Network.TLS.Packet+import Network.TLS.Struct import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert, xor)@@ -39,14 +44,33 @@ -- we just return the compress payload directly as the ciphered one -- encryptRecord :: Record Compressed -> RecordM (Record Ciphertext)-encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do+encryptRecord record@(Record ct ver fragment) = do st <- get case stCipher st of- Nothing -> return bytes- _ -> encryptContent record bytes+ Nothing -> noEncryption+ _ -> do+ recOpts <- getRecordOptions+ if recordTLS13 recOpts+ then encryptContent13+ else onRecordFragment record $ fragmentCipher (encryptContent False record)+ where+ noEncryption = onRecordFragment record $ fragmentCipher return+ encryptContent13+ | ct == ProtocolType_ChangeCipherSpec = noEncryption+ | otherwise = do+ let bytes = fragmentGetBytes fragment+ fragment' = fragmentCompressed $ innerPlaintext ct bytes+ record' = Record ProtocolType_AppData ver fragment'+ onRecordFragment record' $ fragmentCipher (encryptContent True record') -encryptContent :: Record Compressed -> ByteString -> RecordM ByteString-encryptContent record content = do+innerPlaintext :: ProtocolType -> ByteString -> ByteString+innerPlaintext ct bytes = runPut $ do+ putBytes bytes+ putWord8 $ valOfType ct -- non zero!+ -- fixme: zeros padding++encryptContent :: Bool -> Record Compressed -> ByteString -> RecordM ByteString+encryptContent tls13 record content = do cst <- getCryptState bulk <- getBulk case cstKey cst of@@ -59,7 +83,7 @@ let content' = B.concat [content, digest] encryptStream encryptF content' BulkStateAEAD encryptF ->- encryptAead (bulkExplicitIV bulk) encryptF content record+ encryptAead tls13 bulk encryptF content record BulkStateUninitialized -> return content @@ -91,18 +115,24 @@ modify $ \tstate -> tstate { stCryptState = cst { cstKey = BulkStateStream newBulkStream } } return e -encryptAead :: Int+encryptAead :: Bool+ -> Bulk -> BulkAEAD -> ByteString -> Record Compressed -> RecordM ByteString-encryptAead nonceExpLen encryptF content record = do+encryptAead tls13 bulk encryptF content record = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk cst <- getCryptState encodedSeq <- encodeWord64 <$> getMacSequence - let hdr = recordToHeader record- ad = B.concat [encodedSeq, encodeHeader hdr]- iv = cstIV cst+ let iv = cstIV cst ivlen = B.length iv+ Header typ v plainLen = recordToHeader record+ hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen+ hdr = Header typ v hdrLen+ ad | tls13 = encodeHeader hdr+ | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce | nonceExpLen == 0 = B.xor iv sqnc | otherwise = B.concat [iv, encodedSeq]
− Network/TLS/Record/Engage13.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- |--- Module : Network.TLS.Record.Engage13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Engage a record into the Record layer.--- The record is compressed, added some integrity field, then encrypted.----module Network.TLS.Record.Engage13- ( engageRecord- ) where--import Control.Monad.State-import Crypto.Cipher.Types (AuthTag(..))--import Network.TLS.Record.State-import Network.TLS.Record.Types13-import Network.TLS.Cipher-import Network.TLS.Wire-import Network.TLS.Struct (valOfType)-import Network.TLS.Struct13-import Network.TLS.Imports-import Network.TLS.Util-import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert, xor)--engageRecord :: Record13 -> RecordM Record13-engageRecord record@(Record13 ContentType_ChangeCipherSpec _) = return record-engageRecord record@(Record13 ct bytes) = do- st <- get- case stCipher st of- Nothing -> return record- _ -> do- ebytes <- encryptContent $ innerPlaintext ct bytes- return $ Record13 ContentType_AppData ebytes--innerPlaintext :: ContentType -> ByteString -> ByteString-innerPlaintext ct bytes = runPut $ do- putBytes bytes- putWord8 $ valOfType ct -- non zero!- -- fixme: zeros padding--encryptContent :: ByteString -> RecordM ByteString-encryptContent content = do- st <- get- let cst = stCryptState st- case cstKey cst of- BulkStateBlock _ -> error "encryptContent"- BulkStateStream _ -> error "encryptContent"- BulkStateUninitialized -> return content- BulkStateAEAD encryptF -> do- encodedSeq <- encodeWord64 <$> getMacSequence- let iv = cstIV cst- ivlen = B.length iv- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce = B.xor iv sqnc- bulk = cipherBulk $ fromJust "cipher" $ stCipher st- authTagLen = bulkAuthTagLen bulk- plainLen = B.length content- econtentLen = plainLen + authTagLen- additional = "\23\3\3" `B.append` encodeWord16 (fromIntegral econtentLen)- (e, AuthTag authtag) = encryptF nonce content additional- econtent = e `B.append` B.convert authtag- modify incrRecordState- return econtent
Network/TLS/Record/State.hs view
@@ -10,11 +10,13 @@ module Network.TLS.Record.State ( CryptState(..) , MacState(..)+ , RecordOptions(..) , RecordState(..) , newRecordState , incrRecordState , RecordM , runRecordM+ , getRecordOptions , getRecordVersion , setRecordIV , withCompression@@ -50,6 +52,11 @@ { msSequence :: Word64 } deriving (Show) +data RecordOptions = RecordOptions+ { recordVersion :: Version -- version to use when sending/receiving+ , recordTLS13 :: Bool -- TLS13 record processing+ }+ data RecordState = RecordState { stCipher :: Maybe Cipher , stCompression :: Compression@@ -57,7 +64,7 @@ , stMacState :: !MacState } deriving (Show) -newtype RecordM a = RecordM { runRecordM :: Version+newtype RecordM a = RecordM { runRecordM :: RecordOptions -> RecordState -> Either TLSError (a, RecordState) } @@ -67,19 +74,22 @@ instance Monad RecordM where return a = RecordM $ \_ st -> Right (a, st)- m1 >>= m2 = RecordM $ \ver st -> do- case runRecordM m1 ver st of+ m1 >>= m2 = RecordM $ \opt st ->+ case runRecordM m1 opt st of Left err -> Left err- Right (a, st2) -> runRecordM (m2 a) ver st2+ Right (a, st2) -> runRecordM (m2 a) opt st2 instance Functor RecordM where- fmap f m = RecordM $ \ver st ->- case runRecordM m ver st of+ fmap f m = RecordM $ \opt st ->+ case runRecordM m opt st of Left err -> Left err Right (a, st2) -> Right (f a, st2) +getRecordOptions :: RecordM RecordOptions+getRecordOptions = RecordM $ \opt st -> Right (opt, st)+ getRecordVersion :: RecordM Version-getRecordVersion = RecordM $ \ver st -> Right (ver, st)+getRecordVersion = recordVersion <$> getRecordOptions instance MonadState RecordState RecordM where put x = RecordM $ \_ _ -> Right ((), x)@@ -90,9 +100,9 @@ instance MonadError TLSError RecordM where throwError e = RecordM $ \_ _ -> Left e- catchError m f = RecordM $ \ver st ->- case runRecordM m ver st of- Left err -> runRecordM (f err) ver st+ catchError m f = RecordM $ \opt st ->+ case runRecordM m opt st of+ Left err -> runRecordM (f err) opt st r -> r newRecordState :: RecordState
Network/TLS/Record/Types.hs view
@@ -22,6 +22,7 @@ , Fragment , fragmentGetBytes , fragmentPlaintext+ , fragmentCompressed , fragmentCiphertext , Plaintext , Compressed@@ -54,6 +55,9 @@ fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes++fragmentCompressed :: ByteString -> Fragment Compressed+fragmentCompressed bytes = Fragment bytes fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes
− Network/TLS/Record/Types13.hs
@@ -1,24 +0,0 @@--- |--- Module : Network.TLS.Record.Types13--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown-----module Network.TLS.Record.Types13- ( Record13(..)- , rawToRecord13- ) where--import Network.TLS.Struct13-import Network.TLS.Record.Types (Header(..))-import Network.TLS.Imports---- | Represent a TLS record.-data Record13 = Record13 !ContentType ByteString deriving (Show,Eq)---- | turn a header and a fragment into a record-rawToRecord13 :: Header -> ByteString -> Record13-rawToRecord13 (Header pt _ _) fragment = Record13 (protoToContent pt) fragment--- the second arg should be TLS12.
Network/TLS/Sending.hs view
@@ -29,17 +29,21 @@ import Network.TLS.Util import Network.TLS.Imports --- | 'makePacketData' create a Header and a content bytestring related to a packet--- this doesn't change any state-makeRecord :: Packet -> RecordM (Record Plaintext)-makeRecord pkt = do+makeRecord :: ProtocolType -> Fragment Plaintext -> RecordM (Record Plaintext)+makeRecord pt fragment = do ver <- getRecordVersion- return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt)- where writePacketContent (Handshake hss) = encodeHandshakes hss- writePacketContent (Alert a) = encodeAlerts a- writePacketContent ChangeCipherSpec = encodeChangeCipherSpec- writePacketContent (AppData x) = x+ return $ Record pt ver fragment +-- Decompose handshake packets into fragments of the specified length. AppData+-- packets are not fragmented here but by callers of sendPacket, so that the+-- empty-packet countermeasure may be applied to each fragment independently.+getPacketFragments :: Int -> Packet -> [Fragment Plaintext]+getPacketFragments len pkt = map fragmentPlaintext (writePacketContent pkt)+ where writePacketContent (Handshake hss) = getChunks len (encodeHandshakes hss)+ writePacketContent (Alert a) = [encodeAlerts a]+ writePacketContent ChangeCipherSpec = [encodeChangeCipherSpec]+ writePacketContent (AppData x) = [x]+ -- | marshall packet data encodeRecord :: Record Ciphertext -> RecordM ByteString encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]@@ -57,11 +61,18 @@ usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)+ writeFragments ctx pkt writePacket ctx pkt = do- d <- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)+ d <- writeFragments ctx pkt when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx return d++writeFragments :: Context-> Packet -> IO (Either TLSError ByteString)+writeFragments ctx pkt =+ let fragments = getPacketFragments 16384 pkt+ pt = packetType pkt+ in fmap B.concat <$> forEitherM fragments (\frg ->+ prepareRecord ctx (makeRecord pt frg >>= engageRecord >>= encodeRecord)) -- before TLS 1.1, the block cipher IV is made of the residual of the previous block, -- so we use cstIV as is, however in other case we generate an explicit IV
Network/TLS/Sending13.hs view
@@ -19,49 +19,61 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Record (RecordM)-import Network.TLS.Record.Types13-import Network.TLS.Record.Engage13+import Network.TLS.Record.Types+import Network.TLS.Record.Engage import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Context.Internal import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13-import Network.TLS.Wire+import Network.TLS.Util import Network.TLS.Imports -makeRecord :: Packet13 -> RecordM Record13-makeRecord pkt = return $ Record13 (contentType pkt) $ writePacketContent pkt- where writePacketContent (Handshake13 hss) = encodeHandshakes13 hss- writePacketContent (Alert13 a) = encodeAlerts a- writePacketContent (AppData13 x) = x- writePacketContent ChangeCipherSpec13 = encodeChangeCipherSpec+makeRecord :: ProtocolType -> Fragment Plaintext -> RecordM (Record Plaintext)+makeRecord pt fragment =+ return $ Record pt TLS12 fragment -encodeRecord :: Record13 -> RecordM ByteString-encodeRecord (Record13 ct bytes) = return ebytes- where- ebytes = runPut $ do- putWord8 $ fromIntegral $ valOfType ct- putWord16 0x0303 -- TLS12- putWord16 $ fromIntegral $ B.length bytes- putBytes bytes+getPacketFragments :: Int -> Packet13 -> [Fragment Plaintext]+getPacketFragments len pkt = map fragmentPlaintext (writePacketContent pkt)+ where writePacketContent (Handshake13 hss) = getChunks len (encodeHandshakes13 hss)+ writePacketContent (Alert13 a) = [encodeAlerts a]+ writePacketContent (AppData13 x) = [x]+ writePacketContent ChangeCipherSpec13 = [encodeChangeCipherSpec] +encodeRecord :: Record Ciphertext -> RecordM ByteString+encodeRecord record = return $ B.concat [ encodeHeader hdr, content ]+ where (hdr, content) = recordToRaw record+ writePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString) writePacket13 ctx pkt@(Handshake13 hss) = do forM_ hss $ updateHandshake13 ctx- prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)-writePacket13 ctx pkt = prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)+ writeFragments ctx pkt+writePacket13 ctx pkt = writeFragments ctx pkt +writeFragments :: Context -> Packet13 -> IO (Either TLSError ByteString)+writeFragments ctx pkt =+ let fragments = getPacketFragments 16384 pkt+ pt = contentType pkt+ in fmap B.concat <$> forEitherM fragments (\frg ->+ prepareRecord ctx (makeRecord pt frg >>= engageRecord >>= encodeRecord))+ prepareRecord :: Context -> RecordM a -> IO (Either TLSError a) prepareRecord = runTxState updateHandshake13 :: Context -> Handshake13 -> IO ()-updateHandshake13 ctx hs = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded+updateHandshake13 ctx hs+ | isIgnored hs = return ()+ | otherwise = usingHState ctx $ do+ when (isHRR hs) wrapAsMessageHash13+ updateHandshakeDigest encoded+ addHandshakeMessage encoded where encoded = encodeHandshake13 hs isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand isHRR _ = False++ isIgnored NewSessionTicket13{} = True+ isIgnored KeyUpdate13{} = True+ isIgnored _ = False
Network/TLS/State.hs view
@@ -56,6 +56,8 @@ , getTLS13HRR , setTLS13Cookie , getTLS13Cookie+ , setClientSupportsPHA+ , getClientSupportsPHA -- * random , genRandom , withRNG@@ -97,6 +99,7 @@ , stTLS13HRR :: !Bool , stTLS13Cookie :: Maybe Cookie , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3+ , stClientSupportsPHA :: !Bool -- Post-Handshake Authentication (TLS 1.3) } newtype TLSSt a = TLSSt { runTLSSt :: ErrT TLSError (State TLSState) a }@@ -136,6 +139,7 @@ , stTLS13HRR = False , stTLS13Cookie = Nothing , stExporterMasterSecret = Nothing+ , stClientSupportsPHA = False } updateVerifiedData :: Role -> ByteString -> TLSSt ()@@ -287,3 +291,9 @@ getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie++setClientSupportsPHA :: Bool -> TLSSt ()+setClientSupportsPHA b = modify (\st -> st { stClientSupportsPHA = b })++getClientSupportsPHA :: TLSSt Bool+getClientSupportsPHA = gets stClientSupportsPHA
Network/TLS/Struct.hs view
@@ -254,6 +254,7 @@ | BadCertificateHashValue | UnknownPskIdentity | CertificateRequired+ | NoApplicationProtocol -- RFC7301 deriving (Show,Eq) data HandshakeType =@@ -485,6 +486,7 @@ valOfType BadCertificateHashValue = 114 valOfType UnknownPskIdentity = 115 valOfType CertificateRequired = 116+ valOfType NoApplicationProtocol = 120 valToType 0 = Just CloseNotify valToType 10 = Just UnexpectedMessage@@ -518,6 +520,7 @@ valToType 114 = Just BadCertificateHashValue valToType 115 = Just UnknownPskIdentity valToType 116 = Just CertificateRequired+ valToType 120 = Just NoApplicationProtocol valToType _ = Nothing instance TypeValuable CertificateType where
Network/TLS/Struct13.hs view
@@ -10,9 +10,7 @@ , Handshake13(..) , HandshakeType13(..) , typeOfHandshake13- , ContentType(..) , contentType- , protoToContent , KeyUpdate(..) ) where @@ -33,7 +31,6 @@ deriving (Show,Eq) type TicketNonce = ByteString-type CertReqContext = ByteString -- fixme: convert Word32 to proper data type data Handshake13 =@@ -98,35 +95,8 @@ valToType 24 = Just HandshakeType_KeyUpdate13 valToType _ = Nothing -data ContentType =- ContentType_ChangeCipherSpec- | ContentType_Alert- | ContentType_Handshake- | ContentType_AppData- deriving (Eq, Show)---instance TypeValuable ContentType where- valOfType ContentType_ChangeCipherSpec = 20- valOfType ContentType_Alert = 21- valOfType ContentType_Handshake = 22- valOfType ContentType_AppData = 23-- valToType 20 = Just ContentType_ChangeCipherSpec- valToType 21 = Just ContentType_Alert- valToType 22 = Just ContentType_Handshake- valToType 23 = Just ContentType_AppData- valToType _ = Nothing--contentType :: Packet13 -> ContentType-contentType ChangeCipherSpec13 = ContentType_ChangeCipherSpec-contentType (Handshake13 _) = ContentType_Handshake-contentType (Alert13 _) = ContentType_Alert-contentType (AppData13 _) = ContentType_AppData--protoToContent :: ProtocolType -> ContentType-protoToContent ProtocolType_ChangeCipherSpec = ContentType_ChangeCipherSpec-protoToContent ProtocolType_Alert = ContentType_Alert-protoToContent ProtocolType_Handshake = ContentType_Handshake-protoToContent ProtocolType_AppData = ContentType_AppData-protoToContent _ = error "protoToContent"+contentType :: Packet13 -> ProtocolType+contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec+contentType (Handshake13 _) = ProtocolType_Handshake+contentType (Alert13 _) = ProtocolType_Alert+contentType (AppData13 _) = ProtocolType_AppData
Network/TLS/Types.hs view
@@ -9,6 +9,7 @@ ( Version(..) , SessionID , SessionData(..)+ , CertReqContext , TLS13TicketInfo(..) , CipherID , CompressionID@@ -47,6 +48,9 @@ , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int } deriving (Show,Eq)++-- | Certificate request context for TLS 1.3.+type CertReqContext = ByteString data TLS13TicketInfo = TLS13TicketInfo { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds
Network/TLS/Util.hs view
@@ -9,7 +9,12 @@ , bytesEq , fmapEither , catchException+ , forEitherM , mapChunks_+ , getChunks+ , Saved+ , saveMVar+ , restoreMVar ) where import qualified Data.ByteArray as BA@@ -18,6 +23,7 @@ import Control.Exception (SomeException) import Control.Concurrent.Async+import Control.Concurrent.MVar sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len@@ -72,10 +78,33 @@ catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return +forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b])+forEitherM [] _ = return (pure [])+forEitherM (x:xs) f = f x >>= doTail+ where+ doTail (Right b) = fmap (b :) <$> forEitherM xs f+ doTail (Left e) = return (Left e)+ mapChunks_ :: Monad m => Int -> (B.ByteString -> m a) -> B.ByteString -> m ()-mapChunks_ len f bs+mapChunks_ len f = mapM_ f . getChunks len++getChunks :: Int -> B.ByteString -> [B.ByteString]+getChunks len bs | B.length bs > len = let (chunk, remain) = B.splitAt len bs- in f chunk >> mapChunks_ len f remain- | otherwise = void (f bs)+ in chunk : getChunks len remain+ | otherwise = [bs]++-- | An opaque newtype wrapper to prevent from poking inside content that has+-- been saved.+newtype Saved a = Saved a++-- | Save the content of an 'MVar' to restore it later.+saveMVar :: MVar a -> IO (Saved a)+saveMVar ref = Saved <$> readMVar ref++-- | Restore the content of an 'MVar' to a previous saved value and return the+-- content that has just been replaced.+restoreMVar :: MVar a -> Saved a -> IO (Saved a)+restoreMVar ref (Saved val) = Saved <$> swapMVar ref val
Network/TLS/X509.hs view
@@ -41,6 +41,7 @@ CertificateRejectExpired | CertificateRejectRevoked | CertificateRejectUnknownCA+ | CertificateRejectAbsent | CertificateRejectOther String deriving (Show,Eq) @@ -56,4 +57,6 @@ | Expired `elem` l = CertificateUsageReject CertificateRejectExpired | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA+ | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA+ | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent | otherwise = CertificateUsageReject $ CertificateRejectOther (show l)
Tests/Certificate.hs view
@@ -5,6 +5,7 @@ ( arbitraryX509 , arbitraryX509WithKey , arbitraryX509WithKeyAndUsage+ , arbitraryDN , arbitraryKeyUsage , simpleCertificate , simpleX509
Tests/Connection.hs view
@@ -64,7 +64,7 @@ arbitraryCiphers = listOf1 $ elements knownCiphers knownVersions :: [Version]-knownVersions = [SSL3,TLS10,TLS11,TLS12,TLS13]+knownVersions = [TLS13,TLS12,TLS11,TLS10,SSL3] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions@@ -148,7 +148,7 @@ leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing-leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf)+leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ getCertificate leaf) isLeafRSA :: Maybe CertificateChain -> Bool isLeafRSA chain = case chain >>= leafPublicKey of
Tests/Marshalling.hs view
@@ -1,5 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-module Marshalling where+module Marshalling+ ( someWords8+ , prop_header_marshalling_id+ , prop_handshake_marshalling_id+ , prop_handshake13_marshalling_id+ ) where import Control.Monad import Control.Applicative@@ -9,14 +14,14 @@ import qualified Data.ByteString as B import Data.Word-import Data.X509+import Data.X509 (CertificateChain(..)) import Certificate genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i instance Arbitrary Version where- arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12 ]+ arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12, TLS13 ] instance Arbitrary ProtocolType where arbitrary = elements@@ -41,6 +46,34 @@ 2 -> Session . Just <$> genByteString 32 _ -> return $ Session Nothing +instance Arbitrary HashAlgorithm where+ arbitrary = elements+ [ Network.TLS.HashNone+ , Network.TLS.HashMD5+ , Network.TLS.HashSHA1+ , Network.TLS.HashSHA224+ , Network.TLS.HashSHA256+ , Network.TLS.HashSHA384+ , Network.TLS.HashSHA512+ , Network.TLS.HashIntrinsic+ ]++instance Arbitrary SignatureAlgorithm where+ arbitrary = elements+ [ SignatureAnonymous+ , SignatureRSA+ , SignatureDSS+ , SignatureECDSA+ , SignatureRSApssRSAeSHA256+ , SignatureRSApssRSAeSHA384+ , SignatureRSApssRSAeSHA512+ , SignatureEd25519+ , SignatureEd448+ , SignatureRSApsspssSHA256+ , SignatureRSApsspssSHA384+ , SignatureRSApsspssSHA512+ ]+ instance Arbitrary DigitallySigned where arbitrary = DigitallySigned Nothing <$> genByteString 32 @@ -53,6 +86,16 @@ someWords8 :: Int -> Gen [Word8] someWords8 = vector +instance Arbitrary ExtensionRaw where+ arbitrary =+ let arbitraryContent = choose (0,40) >>= genByteString+ in ExtensionRaw <$> arbitrary <*> arbitraryContent++arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw]+arbitraryHelloExtensions ver+ | ver >= SSL3 = arbitrary+ | otherwise = return [] -- no hello extension with SSLv2+ instance Arbitrary CertificateType where arbitrary = elements [ CertificateType_RSA_Sign, CertificateType_DSS_Sign@@ -62,31 +105,54 @@ instance Arbitrary Handshake where arbitrary = oneof- [ ClientHello+ [ arbitrary >>= \ver -> ClientHello ver <$> arbitrary <*> arbitrary- <*> arbitrary <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs- <*> return []+ <*> arbitraryHelloExtensions ver <*> return Nothing- , ServerHello+ , arbitrary >>= \ver -> ServerHello ver <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary- <*> arbitrary- <*> return []+ <*> arbitraryHelloExtensions ver , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 --, liftM ServerKeyXchg- , liftM3 CertRequest arbitrary (return Nothing) (return [])+ , liftM3 CertRequest arbitrary (return Nothing) (listOf arbitraryDN) , CertVerify <$> arbitrary , Finished <$> genByteString 12 ] +arbitraryCertReqContext :: Gen B.ByteString+arbitraryCertReqContext = oneof [ return B.empty, genByteString 32 ]++instance Arbitrary Handshake13 where+ arbitrary = oneof+ [ NewSessionTicket13+ <$> arbitrary+ <*> arbitrary+ <*> genByteString 32 -- nonce+ <*> genByteString 32 -- session ID+ <*> arbitrary+ , pure EndOfEarlyData13+ , EncryptedExtensions13 <$> arbitrary+ , CertRequest13+ <$> arbitraryCertReqContext+ <*> arbitrary+ , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13+ <$> arbitraryCertReqContext+ <*> return (CertificateChain certs)+ <*> replicateM (length certs) arbitrary+ , CertVerify13 <$> arbitrary <*> genByteString 32+ , Finished13 <$> genByteString 12+ , KeyUpdate13 <$> elements [ UpdateNotRequested, UpdateRequested ]+ ]+ {- quickcheck property -} prop_header_marshalling_id :: Header -> Bool@@ -94,9 +160,17 @@ prop_handshake_marshalling_id :: Handshake -> Bool prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x- where decodeHs b = case decodeHandshakeRecord b of- GotPartial _ -> error "got partial"- GotError e -> error ("got error: " ++ show e)- GotSuccessRemaining _ _ -> error "got remaining byte left"- GotSuccess (ty, content) -> decodeHandshake cp ty content+ where decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA }++prop_handshake13_marshalling_id :: Handshake13 -> Bool+prop_handshake13_marshalling_id x = decodeHs (encodeHandshake13 x) == Right x+ where decodeHs b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b++verifyResult :: (t -> b -> r) -> GetResult (t, b) -> r+verifyResult fn result =+ case result of+ GotPartial _ -> error "got partial"+ GotError e -> error ("got error: " ++ show e)+ GotSuccessRemaining _ _ -> error "got remaining byte left"+ GotSuccess (ty, content) -> fn ty content
Tests/Tests.hs view
@@ -20,6 +20,7 @@ import qualified Data.ByteString.Lazy as L import Network.TLS import Network.TLS.Extra+import Network.TLS.Internal import Control.Applicative import Control.Concurrent import Control.Concurrent.Async@@ -116,6 +117,30 @@ Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) byeBye ctx +runTLSPipeCapture13 :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13])+runTLSPipeCapture13 params = do+ sRef <- run $ newIORef []+ cRef <- run $ newIORef []+ runTLSPipe params (tlsServer sRef) (tlsClient cRef)+ sReceived <- run $ readIORef sRef+ cReceived <- run $ readIORef cRef+ return (reverse sReceived, reverse cReceived)+ where tlsServer ref ctx queue = do+ installHook ctx ref+ handshake ctx+ d <- recvData ctx+ writeChan queue [d]+ bye ctx+ tlsClient ref queue ctx = do+ installHook ctx ref+ handshake ctx+ d <- readChan queue+ sendData ctx (L.fromChunks [d])+ byeBye ctx+ installHook ctx ref =+ let recv hss = modifyIORef ref (hss :) >> return hss+ in contextHookSetHandshake13Recv ctx recv+ runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO () runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient where tlsServer ctx queue = do@@ -415,6 +440,20 @@ | otherwise = (RTT0, Just earlyData) runTLSPipeSimple13 params2 mode mEarlyData +prop_handshake13_ee_groups :: PropertyM IO ()+prop_handshake13_ee_groups = do+ (cli, srv) <- pick arbitraryPairParams13+ let cliSupported = (clientSupported cli) { supportedGroups = [P256,X25519] }+ svrSupported = (serverSupported srv) { supportedGroups = [X25519,P256] }+ params = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported }+ )+ (_, serverMessages) <- runTLSPipeCapture13 params+ let isNegotiatedGroups (ExtensionRaw eid _) = eid == 0xa+ eeMessagesHaveExt = [ any isNegotiatedGroups exts |+ EncryptedExtensions13 exts <- serverMessages ]+ [True] `assertEq` eeMessagesHaveExt -- one EE message with extension+ prop_handshake_ciphersuites :: PropertyM IO () prop_handshake_ciphersuites = do tls13 <- pick arbitrary@@ -594,7 +633,7 @@ prop_handshake_srv_key_usage :: PropertyM IO () prop_handshake_srv_key_usage = do tls13 <- pick arbitrary- let versions = if tls13 then [TLS13] else [SSL3,TLS10,TLS11,TLS12]+ let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3] ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA , cipher_TLS13_AES128GCM_SHA256 , cipher_DHE_RSA_AES128_SHA1@@ -637,6 +676,48 @@ | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) +prop_post_handshake_auth :: PropertyM IO ()+prop_post_handshake_auth = do+ (clientParam,serverParam) <- pick arbitraryPairParams13+ cred <- pick (arbitraryClientCredential TLS13)+ let clientParam' = clientParam { clientHooks = (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred }+ }+ serverParam' = serverParam { serverHooks = (serverHooks serverParam)+ { onClientCertificate = validateChain cred }+ }+ if isCredentialDSA cred+ then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient+ else runTLSPipe (clientParam',serverParam') tlsServer tlsClient+ where validateChain cred chain+ | chain == fst cred = return CertificateUsageAccept+ | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)+ tlsServer ctx queue = do+ hsServer ctx+ d <- recvData ctx+ writeChan queue [d]+ bye ctx+ tlsClient queue ctx = do+ hsClient ctx+ d <- readChan queue+ sendData ctx (L.fromChunks [d])+ byeBye ctx+ hsServer ctx = do+ handshake ctx+ recvDataAssert ctx "request 1"+ _ <- requestCertificate ctx -- single request+ sendData ctx "response 1"+ recvDataAssert ctx "request 2"+ _ <- requestCertificate ctx+ _ <- requestCertificate ctx -- two simultaneously+ sendData ctx "response 2"+ hsClient ctx = do+ handshake ctx+ sendData ctx "request 1"+ recvDataAssert ctx "response 1"+ sendData ctx "request 2"+ recvDataAssert ctx "response 2"+ prop_handshake_clt_key_usage :: PropertyM IO () prop_handshake_clt_key_usage = do (clientParam,serverParam) <- pick arbitraryPairParams@@ -765,10 +846,8 @@ byeBye ctx runReaderWriters ctx r w = -- run concurrently 10 readers and 10 writers on the same context- let workers = concat $ replicate 10 [reader ctx r, writer ctx w]+ let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] in runConcurrently $ traverse_ Concurrently workers- writer = sendData- reader ctx val = do { bs <- recvData ctx; val `assertEq` bs } assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)@@ -777,6 +856,11 @@ assertIsLeft (Left _) = return () assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") +recvDataAssert :: Context -> C8.ByteString -> IO ()+recvDataAssert ctx expected = do+ got <- recvData ctx+ assertEq expected got+ main :: IO () main = defaultMain $ testGroup "tls" [ tests_marshalling@@ -788,6 +872,7 @@ tests_marshalling = testGroup "Marshalling" [ testProperty "Header" prop_header_marshalling_id , testProperty "Handshake" prop_handshake_marshalling_id+ , testProperty "Handshake13" prop_handshake13_marshalling_id ] tests_ciphers = testGroup "Ciphers" [ testProperty "Bulk" propertyBulkFunctional ]@@ -819,6 +904,8 @@ , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length)+ , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups)+ , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) ] -- test concurrent reads and writes
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.5.0+Version: 1.5.1 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -105,13 +105,11 @@ Network.TLS.Packet Network.TLS.Packet13 Network.TLS.Parameters+ Network.TLS.PostHandshake Network.TLS.Record Network.TLS.Record.Types- Network.TLS.Record.Types13 Network.TLS.Record.Engage- Network.TLS.Record.Engage13 Network.TLS.Record.Disengage- Network.TLS.Record.Disengage13 Network.TLS.Record.State Network.TLS.RNG Network.TLS.State