tls 2.1.6 → 2.1.7
raw patch · 57 files changed
+2140/−1417 lines, 57 filesdep +zlib
Dependencies added: zlib
Files
- CHANGELOG.md +16/−0
- Network/TLS.hs +11/−1
- Network/TLS/Context.hs +22/−7
- Network/TLS/Context/Internal.hs +82/−4
- Network/TLS/Core.hs +6/−3
- Network/TLS/Credentials.hs +5/−0
- Network/TLS/Extension.hs +148/−30
- Network/TLS/Handshake/Client/ClientHello.hs +81/−67
- Network/TLS/Handshake/Client/ServerHello.hs +41/−13
- Network/TLS/Handshake/Client/TLS12.hs +1/−0
- Network/TLS/Handshake/Client/TLS13.hs +29/−7
- Network/TLS/Handshake/Common.hs +30/−1
- Network/TLS/Handshake/Common13.hs +33/−14
- Network/TLS/Handshake/Process.hs +1/−2
- Network/TLS/Handshake/Random.hs +0/−43
- Network/TLS/Handshake/Server.hs +3/−1
- Network/TLS/Handshake/Server/ClientHello12.hs +2/−1
- Network/TLS/Handshake/Server/ClientHello13.hs +13/−12
- Network/TLS/Handshake/Server/Common.hs +42/−19
- Network/TLS/Handshake/Server/ServerHello12.hs +48/−40
- Network/TLS/Handshake/Server/ServerHello13.hs +38/−25
- Network/TLS/Handshake/Server/TLS12.hs +1/−0
- Network/TLS/Handshake/Server/TLS13.hs +28/−13
- Network/TLS/Handshake/State.hs +20/−0
- Network/TLS/HashAndSignature.hs +48/−7
- Network/TLS/IO.hs +87/−60
- Network/TLS/IO/Decode.hs +93/−0
- Network/TLS/IO/Encode.hs +123/−0
- Network/TLS/Internal.hs +6/−4
- Network/TLS/Packet.hs +148/−116
- Network/TLS/Packet13.hs +84/−45
- Network/TLS/Parameters.hs +45/−1
- Network/TLS/QUIC.hs +8/−2
- Network/TLS/Receiving.hs +0/−93
- Network/TLS/Record.hs +5/−6
- Network/TLS/Record/Decrypt.hs +206/−0
- Network/TLS/Record/Disengage.hs +0/−202
- Network/TLS/Record/Encrypt.hs +130/−0
- Network/TLS/Record/Engage.hs +0/−139
- Network/TLS/Record/Layer.hs +2/−2
- Network/TLS/Record/Reading.hs +0/−103
- Network/TLS/Record/Recv.hs +112/−0
- Network/TLS/Record/Send.hs +61/−0
- Network/TLS/Record/Types.hs +6/−29
- Network/TLS/Record/Writing.hs +0/−59
- Network/TLS/Sending.hs +0/−124
- Network/TLS/Struct.hs +93/−52
- Network/TLS/Struct13.hs +17/−10
- Network/TLS/Types.hs +7/−4
- Network/TLS/Types/Cipher.hs +0/−1
- Network/TLS/Types/Version.hs +1/−1
- Network/TLS/X509.hs +21/−0
- test/Arbitrary.hs +5/−10
- tls.cabal +13/−12
- util/Server.hs +49/−24
- util/tls-client.hs +27/−3
- util/tls-server.hs +42/−5
CHANGELOG.md view
@@ -1,3 +1,19 @@+# Change log for "tls"++## Version 2.1.7++* Introducing `Limit` parameter.+* Implementing "Record Size Limit Extension for TLS" (RFC8449).+ Set `limitRecordSize` use it.+* Implementing "TLS Certificate Compression" (RFC 8879).+ This feature is automatically used if the peer supports it.+* More tests with `tlsfuzzer` especially for client authentication+ and 0-RTT.+* Implementing a utility funcation, `validateClientCertificate`, for+ client authentication.+* Bug fix for echo back logic of Cookie extension.+* More pretty show for the internal `Handshake` structure for debugging.+ ## Version 2.1.6 * Testing with "tlsfuzzer" again. Now don't send an alert agaist to
Network/TLS.hs view
@@ -42,7 +42,6 @@ -- ** Client parameters ClientParams, defaultParamsClient,- clientUseMaxFragmentLength, clientServerIdentification, clientUseServerNameIndication, clientWantSessionResume,@@ -51,6 +50,7 @@ clientHooks, clientSupported, clientDebug,+ clientLimit, clientUseEarlyData, -- ** Server parameters@@ -63,6 +63,7 @@ serverShared, serverSupported, serverDebug,+ serverLimit, serverEarlyDataSize, serverTicketLifetime, @@ -82,6 +83,7 @@ onCertificateRequest, OnServerCertificate, onServerCertificate,+ validateClientCertificate, onSuggestALPN, onCustomFFDHEGroup, onServerFinished,@@ -124,6 +126,12 @@ debugVersionForced, debugKeyLogger, + -- ** Limit parameters+ Limit,+ defaultLimit,+ limitHandshakeFragment,+ limitRecordSize,+ -- * Shared parameters -- ** Credentials@@ -191,6 +199,7 @@ CertificateUsage (..), CertificateRejectReason (..), CertificateType (..),+ CertificateChain (..), HostName, MaxFragmentEnum (..), @@ -287,6 +296,7 @@ Bytes, ValidationChecks (..), ValidationHooks (..),+ clientUseMaxFragmentLength, ) where import Network.TLS.Backend (Backend (..), HasBackend (..))
Network/TLS/Context.hs view
@@ -58,6 +58,15 @@ TLS13State (..), getTLS13State, modifyTLS13State,+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef, ) where import Control.Concurrent.MVar@@ -87,13 +96,13 @@ requestCertificateServer, ) import Network.TLS.RNG-import Network.TLS.Record.Reading+import Network.TLS.Record.Recv+import Network.TLS.Record.Send import Network.TLS.Record.State-import Network.TLS.Record.Writing import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13-import Network.TLS.Types (Role (..))+import Network.TLS.Types (Role (..), defaultRecordSizeLimit) import Network.TLS.X509 class TLSParams a where@@ -109,6 +118,7 @@ ( clientSupported cparams , clientShared cparams , clientDebug cparams+ , clientLimit cparams ) getTLSRole _ = ClientRole doHandshake = handshakeClient@@ -121,6 +131,7 @@ ( serverSupported sparams , serverShared sparams , serverDebug sparams+ , serverLimit sparams ) getTLSRole _ = ServerRole doHandshake = handshakeServer@@ -139,7 +150,7 @@ contextNew backend params = liftIO $ do initializeBackend backend - let (supported, shared, debug) = getTLSCommonParams params+ let (supported, shared, debug, limit) = getTLSCommonParams params seed <- case debugSeed debug of Nothing -> do@@ -166,6 +177,8 @@ crs <- newIORef [] locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State+ mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit let roleParams = RoleParams { doHandshake_ = doHandshake params@@ -179,8 +192,10 @@ { ctxBackend = getBackend backend , ctxShared = shared , ctxSupported = supported+ , ctxLimit = limit , ctxTLSState = tlsstate- , ctxFragmentSize = Just 16384+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxTxRecordState = tx , ctxRxRecordState = rx , ctxHandshakeState = hs@@ -205,10 +220,10 @@ recordLayer = RecordLayer- { recordEncode = encodeRecord+ { recordEncode12 = encodeRecord12 , recordEncode13 = encodeRecord13 , recordSendBytes = sendBytes- , recordRecv = recvRecord+ , recordRecv12 = recvRecord12 , recordRecv13 = recvRecord13 }
Network/TLS/Context/Internal.hs view
@@ -16,6 +16,7 @@ -- * Context object and accessor Context (..), Hooks (..),+ Limit (..), Established (..), PendingRecvAction (..), RecordLayer (..),@@ -69,6 +70,17 @@ modifyTLS13State, CipherChoice (..), makeCipherChoice,++ -- * RecordLimit+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef, ) where import Control.Concurrent.MVar@@ -105,6 +117,7 @@ -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared+ , ctxLimit :: Limit , ctxTLSState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool@@ -135,10 +148,19 @@ , -- Misc ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability.- , ctxFragmentSize :: Maybe Int- -- ^ maximum size of plaintext fragments+ , ctxMyRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxPeerRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3 } +data RecordLimit+ = NoRecordLimit -- for QUIC+ | RecordLimit+ Int -- effective+ (Maybe Int) -- pending+ deriving (Eq, Show)+ data RoleParams = RoleParams { doHandshake_ :: Context -> IO () , doHandshakeWith_ :: Context -> Handshake -> IO ()@@ -223,11 +245,11 @@ {- FOURMOLU_DISABLE -} data RecordLayer a = RecordLayer { -- Writing.hs- recordEncode :: Context -> Record Plaintext -> IO (Either TLSError a)+ recordEncode12 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordEncode13 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordSendBytes :: Context -> a -> IO () , -- Reading.hs- recordRecv :: Context -> Int -> IO (Either TLSError (Record Plaintext))+ recordRecv12 :: Context -> IO (Either TLSError (Record Plaintext)) , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext)) } {- FOURMOLU_ENABLE -}@@ -448,3 +470,59 @@ where fromCertRequest13 (CertRequest13 c _) = c fromCertRequest13 _ = error "fromCertRequest13"++--------------------------------++setMyRecordLimit :: Context -> Maybe Int -> IO ()+setMyRecordLimit ctx msiz = modifyIORef (ctxMyRecordLimit ctx) change+ where+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enableMyRecordLimit :: Context -> IO ()+enableMyRecordLimit ctx = modifyIORef (ctxMyRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getMyRecordLimit :: Context -> IO (Maybe Int)+getMyRecordLimit ctx = change <$> readIORef (ctxMyRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkMyRecordLimit :: Context -> IO Bool+checkMyRecordLimit ctx = chk <$> readIORef (ctxMyRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++--------------------------------++setPeerRecordLimit :: Context -> Maybe Int -> IO ()+setPeerRecordLimit ctx msiz = modifyIORef (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enablePeerRecordLimit :: Context -> IO ()+enablePeerRecordLimit ctx = modifyIORef (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getPeerRecordLimit :: Context -> IO (Maybe Int)+getPeerRecordLimit ctx = change <$> readIORef (ctxPeerRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkPeerRecordLimit :: Context -> IO Bool+checkPeerRecordLimit ctx = chk <$> readIORef (ctxPeerRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++newRecordLimitRef :: Maybe Int -> IO (IORef RecordLimit)+newRecordLimitRef Nothing = newIORef NoRecordLimit+newRecordLimitRef (Just n) = newIORef $ RecordLimit n Nothing
Network/TLS/Core.hs view
@@ -42,7 +42,6 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Process-import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO@@ -192,8 +191,8 @@ -- All chunks are protected with the same write lock because we don't -- want to interleave writes from other threads in the middle of our -- possibly large write.- let len = ctxFragmentSize ctx- mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend)+ mlen <- getPeerRecordLimit ctx -- plaintext, dont' adjust for TLS 1.3+ mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF.@@ -334,6 +333,10 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hs loopHandshake13 (KeyUpdate13 mode : hs) = do+ let multipleKeyUpdate = any isKeyUpdate13 hs+ when multipleKeyUpdate $ do+ let reason = "Multiple KeyUpdate is not allowed in one record"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason
Network/TLS/Credentials.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Network.TLS.Credentials ( Credential,@@ -25,6 +27,9 @@ import qualified Network.TLS.Struct as TLS type Credential = (CertificateChain, PrivKey)++instance {-# OVERLAPS #-} Show Credential where+ show (cc, _) = TLS.showCertificateChain cc newtype Credentials = Credentials [Credential] deriving (Show)
Network/TLS/Extension.hs view
@@ -30,6 +30,8 @@ EID_Padding, EID_EncryptThenMAC, EID_ExtendedMainSecret,+ EID_CompressCertificate,+ EID_RecordSizeLimit, EID_SessionTicket, EID_PreSharedKey, EID_EarlyData,@@ -65,6 +67,8 @@ SecureRenegotiation (..), ApplicationLayerProtocolNegotiation (..), ExtendedMainSecret (..),+ CertificateCompressionAlgorithm (.., CCA_Zlib, CCA_Brotli, CCA_Zstd),+ CompressCertificate (..), SupportedGroups (..), Group (..), EcPointFormatsSupported (..),@@ -74,6 +78,7 @@ EcPointFormat_AnsiX962_compressed_prime, EcPointFormat_AnsiX962_compressed_char2 ),+ RecordSizeLimit (..), SessionTicket (..), HeartBeat (..), HeartBeatMode (@@ -173,6 +178,10 @@ pattern EID_EncryptThenMAC = ExtensionID 0x16 pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627 pattern EID_ExtendedMainSecret = ExtensionID 0x17+pattern EID_CompressCertificate :: ExtensionID -- RFC8879+pattern EID_CompressCertificate = ExtensionID 0x1b+pattern EID_RecordSizeLimit :: ExtensionID -- RFC8449+pattern EID_RecordSizeLimit = ExtensionID 0x1c pattern EID_SessionTicket :: ExtensionID -- RFC4507 pattern EID_SessionTicket = ExtensionID 0x23 pattern EID_PreSharedKey :: ExtensionID -- RFC8446@@ -225,6 +234,8 @@ show EID_Padding = "Padding" show EID_EncryptThenMAC = "EncryptThenMAC" show EID_ExtendedMainSecret = "ExtendedMainSecret"+ show EID_CompressCertificate = "CompressCertificate"+ show EID_RecordSizeLimit = "RecordSizeLimit" show EID_SessionTicket = "SessionTicket" show EID_PreSharedKey = "PreSharedKey" show EID_EarlyData = "EarlyData"@@ -238,7 +249,7 @@ show EID_KeyShare = "KeyShare" show EID_QuicTransportParameters = "QuicTransportParameters" show EID_SecureRenegotiation = "SecureRenegotiation"- show (ExtensionID x) = "ExtensionID " ++ show x+ show (ExtensionID x) = "ExtensionID " ++ show x {- FOURMOLU_ENABLE -} ------------------------------------------------------------@@ -269,6 +280,8 @@ , EID_Padding , EID_EncryptThenMAC , EID_ExtendedMainSecret+ , EID_CompressCertificate+ , EID_RecordSizeLimit , EID_SessionTicket , EID_PreSharedKey , EID_EarlyData@@ -289,13 +302,13 @@ supportedExtensions :: [ExtensionID] supportedExtensions = [ EID_ServerName -- 0x00- , EID_MaxFragmentLength -- 0x01 , EID_SupportedGroups -- 0x0a , EID_EcPointFormats -- 0x0b , EID_SignatureAlgorithms -- 0x0d- , EID_Heartbeat -- 0x0f , EID_ApplicationLayerProtocolNegotiation -- 0x10 , EID_ExtendedMainSecret -- 0x17+ , EID_CompressCertificate -- 0x1b+ , EID_RecordSizeLimit -- 0x1c , EID_SessionTicket -- 0x23 , EID_PreSharedKey -- 0x29 , EID_EarlyData -- 0x2a@@ -326,16 +339,18 @@ show (ExtensionRaw eid@EID_Heartbeat bs) = showExtensionRaw eid bs decodeHeartBeat show (ExtensionRaw eid@EID_ApplicationLayerProtocolNegotiation bs) = showExtensionRaw eid bs decodeApplicationLayerProtocolNegotiation show (ExtensionRaw eid@EID_ExtendedMainSecret _) = show eid+ show (ExtensionRaw eid@EID_CompressCertificate bs) = showExtensionRaw eid bs decodeCompressCertificate+ show (ExtensionRaw eid@EID_RecordSizeLimit bs) = showExtensionRaw eid bs decodeRecordSizeLimit show (ExtensionRaw eid@EID_SessionTicket bs) = showExtensionRaw eid bs decodeSessionTicket show (ExtensionRaw eid@EID_PreSharedKey bs) = show eid ++ " " ++ showBytesHex bs show (ExtensionRaw eid@EID_EarlyData _) = show eid- show (ExtensionRaw eid@EID_SupportedVersions bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid@EID_SupportedVersions bs) = showExtensionRaw eid bs decodeSupportedVersions show (ExtensionRaw eid@EID_Cookie bs) = show eid ++ " " ++ showBytesHex bs show (ExtensionRaw eid@EID_PskKeyExchangeModes bs) = showExtensionRaw eid bs decodePskKeyExchangeModes show (ExtensionRaw eid@EID_CertificateAuthorities bs) = showExtensionRaw eid bs decodeCertificateAuthorities show (ExtensionRaw eid@EID_PostHandshakeAuth _) = show eid show (ExtensionRaw eid@EID_SignatureAlgorithmsCert bs) = showExtensionRaw eid bs decodeSignatureAlgorithmsCert- show (ExtensionRaw eid@EID_KeyShare bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid@EID_KeyShare bs) = showExtensionRaw eid bs decodeKeyShare show (ExtensionRaw eid@EID_SecureRenegotiation bs) = show eid ++ " " ++ showBytesHex bs show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs @@ -570,6 +585,7 @@ getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) leftoverLen <- remaining when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length"+ when (null sas) $ fail "signature algorithms are empty" return $ SignatureAlgorithms sas ------------------------------------------------------------@@ -642,6 +658,68 @@ ------------------------------------------------------------ +newtype CertificateCompressionAlgorithm+ = CertificateCompressionAlgorithm Word16+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern CCA_Zlib :: CertificateCompressionAlgorithm+pattern CCA_Zlib = CertificateCompressionAlgorithm 1+pattern CCA_Brotli :: CertificateCompressionAlgorithm+pattern CCA_Brotli = CertificateCompressionAlgorithm 2+pattern CCA_Zstd :: CertificateCompressionAlgorithm+pattern CCA_Zstd = CertificateCompressionAlgorithm 3++instance Show CertificateCompressionAlgorithm where+ show CCA_Zlib = "zlib"+ show CCA_Brotli = "brotli"+ show CCA_Zstd = "zstd"+ show (CertificateCompressionAlgorithm n) = "CertificateCompressionAlgorithm " ++ show n+{- FOURMOLU_ENABLE -}++newtype CompressCertificate = CompressCertificate [CertificateCompressionAlgorithm]+ deriving (Show, Eq)++instance Extension CompressCertificate where+ extensionID _ = EID_CompressCertificate+ extensionEncode (CompressCertificate cs) = runPut $ do+ putWord8 $ fromIntegral (length cs * 2)+ mapM_ putCCA cs+ where+ putCCA (CertificateCompressionAlgorithm n) = putWord16 n+ extensionDecode _ = decodeCompressCertificate++decodeCompressCertificate :: ByteString -> Maybe CompressCertificate+decodeCompressCertificate = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ cs <- getList len getCCA+ when (null cs) $ fail "empty list of CertificateCompressionAlgorithm"+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeCompressCertificate: broken length"+ return $ CompressCertificate cs+ where+ getCCA = do+ cca <- CertificateCompressionAlgorithm <$> getWord16+ return (2, cca)++------------------------------------------------------------++newtype RecordSizeLimit = RecordSizeLimit Word16 deriving (Eq, Show)++instance Extension RecordSizeLimit where+ extensionID _ = EID_RecordSizeLimit+ extensionEncode (RecordSizeLimit n) = runPut $ putWord16 n+ extensionDecode _ = decodeRecordSizeLimit++decodeRecordSizeLimit :: ByteString -> Maybe RecordSizeLimit+decodeRecordSizeLimit = runGetMaybe $ do+ r <- RecordSizeLimit <$> getWord16+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeRecordSizeLimit: broken length"+ return r++------------------------------------------------------------+ newtype SessionTicket = SessionTicket Ticket deriving (Show, Eq) @@ -722,8 +800,12 @@ data SupportedVersions = SupportedVersionsClientHello [Version] | SupportedVersionsServerHello Version- deriving (Show, Eq)+ deriving (Eq) +instance Show SupportedVersions where+ show (SupportedVersionsClientHello vers) = "Versions " ++ show vers+ show (SupportedVersionsServerHello ver) = "Versions " ++ show ver+ instance Extension SupportedVersions where extensionID _ = EID_SupportedVersions extensionEncode (SupportedVersionsClientHello vers) = runPut $ do@@ -732,17 +814,28 @@ extensionEncode (SupportedVersionsServerHello ver) = runPut $ putBinaryVersion ver- extensionDecode MsgTClientHello = runGetMaybe $ do- len <- fromIntegral <$> getWord8- SupportedVersionsClientHello <$> getList len getVer- where- getVer = do- ver <- getBinaryVersion- return (2, ver)- extensionDecode MsgTServerHello =- runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion)+ extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello+ extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello" +decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ SupportedVersionsClientHello <$> getList len getVer+ where+ getVer = do+ ver <- getBinaryVersion+ return (2, ver)++decodeSupportedVersionsServerHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsServerHello =+ runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion)++decodeSupportedVersions :: ByteString -> Maybe SupportedVersions+decodeSupportedVersions bs =+ decodeSupportedVersionsClientHello bs+ <|> decodeSupportedVersionsServerHello bs+ ------------------------------------------------------------ newtype Cookie = Cookie ByteString deriving (Eq, Show)@@ -841,8 +934,11 @@ { keyShareEntryGroup :: Group , keyShareEntryKeyExchange :: ByteString }- deriving (Show, Eq)+ deriving (Eq) +instance Show KeyShareEntry where+ show kse = show $ keyShareEntryGroup kse+ getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) getKeyShareEntry = do grp <- Group <$> getWord16@@ -861,8 +957,15 @@ = KeyShareClientHello [KeyShareEntry] | KeyShareServerHello KeyShareEntry | KeyShareHRR Group- deriving (Show, Eq)+ deriving (Eq) +{- FOURMOLU_DISABLE -}+instance Show KeyShare where+ show (KeyShareClientHello kses) = "KeyShare " ++ show kses+ show (KeyShareServerHello kse) = "KeyShare " ++ show kse+ show (KeyShareHRR g) = "KeyShare " ++ show g+{- FOURMOLU_ENABLE -}+ instance Extension KeyShare where extensionID _ = EID_KeyShare extensionEncode (KeyShareClientHello kses) = runPut $ do@@ -871,20 +974,35 @@ mapM_ putKeyShareEntry kses extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse extensionEncode (KeyShareHRR (Group grp)) = runPut $ putWord16 grp- extensionDecode MsgTServerHello = runGetMaybe $ do- (_, ment) <- getKeyShareEntry- case ment of- Nothing -> fail "decoding KeyShare for ServerHello"- Just ent -> return $ KeyShareServerHello ent- extensionDecode MsgTClientHello = runGetMaybe $ do- len <- fromIntegral <$> getWord16- -- len == 0 allows for HRR- grps <- getList len getKeyShareEntry- return $ KeyShareClientHello $ catMaybes grps- extensionDecode MsgTHelloRetryRequest =- runGetMaybe $- KeyShareHRR . Group <$> getWord16+ extensionDecode MsgTClientHello = decodeKeyShareClientHello+ extensionDecode MsgTServerHello = decodeKeyShareServerHello+ extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR extensionDecode _ = error "extensionDecode: KeyShare"++decodeKeyShareClientHello :: ByteString -> Maybe KeyShare+decodeKeyShareClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord16+ -- len == 0 allows for HRR+ grps <- getList len getKeyShareEntry+ return $ KeyShareClientHello $ catMaybes grps++decodeKeyShareServerHello :: ByteString -> Maybe KeyShare+decodeKeyShareServerHello = runGetMaybe $ do+ (_, ment) <- getKeyShareEntry+ case ment of+ Nothing -> fail "decoding KeyShare for ServerHello"+ Just ent -> return $ KeyShareServerHello ent++decodeKeyShareHRR :: ByteString -> Maybe KeyShare+decodeKeyShareHRR =+ runGetMaybe $+ KeyShareHRR . Group <$> getWord16++decodeKeyShare :: ByteString -> Maybe KeyShare+decodeKeyShare bs =+ decodeKeyShareClientHello bs+ <|> decodeKeyShareServerHello bs+ <|> decodeKeyShareHRR bs ------------------------------------------------------------
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -89,6 +89,7 @@ let cipherIds = map (CipherId . cipherID) ciphers compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts+ setMyRecordLimit ctx $ limitRecordSize $ clientLimit cparams extensions0 <- catMaybes <$> getExtensions let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0 extensions <- adjustExtentions extensions1 $ mkClientHello extensions1@@ -117,43 +118,28 @@ -- (not always present) have length > 0. getExtensions = sequence- [ sniExtension- , secureReneg- , alpnExtension- , emsExtension- , groupExtension- , ecPointExtension- , sessionTicketExtension- , signatureAlgExtension- , -- , heartbeatExtension- versionExtension- , earlyDataExtension- , keyshareExtension- , cookieExtension- , postHandshakeAuthExtension- , pskExchangeModeExtension- , preSharedKeyExtension -- MUST be last (RFC 8446)+ [ {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x0b -} ecPointExt+ , {- 0x0d -} signatureAlgExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1b -} compCertExt+ , {- 0x1c -} recordSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0x2a -} earlyDataExt+ , {- 0x2b -} versionExt+ , {- 0x2c -} cookieExt+ , {- 0x2d -} pskExchangeModeExt+ , {- 0x31 -} postHandshakeAuthExt+ , {- 0x33 -} keyShareExt+ , {- 0xff01 -} secureRenegExt+ , {- 0x29 -} preSharedKeyExt -- MUST be last (RFC 8446) ] - secureReneg =- if supportedSecureRenegotiation $ ctxSupported ctx- then do- VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole- return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""- else return Nothing- alpnExtension = do- mprotos <- onSuggestALPN $ clientHooks cparams- case mprotos of- Nothing -> return Nothing- Just protos -> do- usingState_ ctx $ setClientALPNSuggest protos- return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos- emsExtension =- return $- if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)- then Nothing- else Just $ toExtensionRaw ExtendedMainSecret- sniExtension =+ --------------------++ sniExt = if clientUseServerNameIndication cparams then do let sni = fst $ clientServerIdentification cparams@@ -161,26 +147,19 @@ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - groupExtension =+ groupExt = return $ Just $ toExtensionRaw $ SupportedGroups (supportedGroups $ ctxSupported ctx)- ecPointExtension =++ ecPointExt = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]- -- [EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]- -- heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend - sessionTicketExtension = do- case clientSessions cparams of- (sidOrTkt, _) : _- | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt- _ -> return $ Just $ toExtensionRaw $ SessionTicket ""-- signatureAlgExtension =+ signatureAlgExt = return $ Just $ toExtensionRaw $@@ -188,14 +167,59 @@ supportedHashSignatures $ clientSupported cparams - versionExtension+ alpnExt = do+ mprotos <- onSuggestALPN $ clientHooks cparams+ case mprotos of+ Nothing -> return Nothing+ Just protos -> do+ usingState_ ctx $ setClientALPNSuggest protos+ return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos++ emsExt =+ return $+ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)+ then Nothing+ else Just $ toExtensionRaw ExtendedMainSecret++ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib])++ recordSizeLimitExt = case limitRecordSize $ clientLimit cparams of+ Nothing -> return Nothing+ Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz++ sessionTicketExt = do+ case clientSessions cparams of+ (sidOrTkt, _) : _+ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt+ _ -> return $ Just $ toExtensionRaw $ SessionTicket ""++ earlyDataExt+ | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)+ | otherwise = return Nothing++ versionExt | tls13 = do let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers | otherwise = return Nothing + cookieExt = do+ mcookie <- usingState_ ctx getTLS13Cookie+ case mcookie of+ Nothing -> return Nothing+ Just cookie -> return $ Just $ toExtensionRaw cookie++ pskExchangeModeExt+ | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]+ | otherwise = return Nothing++ postHandshakeAuthExt+ | ctxQUICMode ctx = return Nothing+ | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth+ | otherwise = return Nothing+ -- FIXME- keyshareExtension+ keyShareExt | tls13 = case groupToSend of Nothing -> return Nothing Just grp -> do@@ -204,7 +228,14 @@ return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] | otherwise = return Nothing - preSharedKeyExtension =+ secureRenegExt =+ if supportedSecureRenegotiation $ ctxSupported ctx+ then do+ VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole+ return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""+ else return Nothing++ preSharedKeyExt = case pskInfo of Nothing -> return Nothing Just (identities, _, choice, obfAge) ->@@ -216,24 +247,7 @@ offeredPsks = PreSharedKeyClientHello pskIdentities binders in return $ Just $ toExtensionRaw offeredPsks - pskExchangeModeExtension- | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]- | otherwise = return Nothing-- earlyDataExtension- | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)- | otherwise = return Nothing-- cookieExtension = do- mcookie <- usingState_ ctx getTLS13Cookie- case mcookie of- Nothing -> return Nothing- Just cookie -> return $ Just $ toExtensionRaw cookie-- postHandshakeAuthExtension- | ctxQUICMode ctx = return Nothing- | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth- | otherwise = return Nothing+ ---------------------------------------- adjustExtentions exts ch = case pskInfo of
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -53,8 +53,8 @@ processServerHello13 :: ClientParams -> Context -> Handshake13 -> IO ()-processServerHello13 cparams ctx (ServerHello13 serverRan serverSession cipher exts) = do- let sh = ServerHello TLS12 serverRan serverSession cipher 0 exts+processServerHello13 cparams ctx (ServerHello13 serverRan serverSession cipher shExts) = do+ let sh = ServerHello TLS12 serverRan serverSession cipher 0 shExts processServerHello cparams ctx sh processServerHello13 _ _ h = unexpected (show h) (Just "server hello") @@ -66,7 +66,7 @@ -- 4) process the session parameter to see if the server want to start a new session or can resume processServerHello :: ClientParams -> Context -> Handshake -> IO ()-processServerHello cparams ctx (ServerHello rver serverRan serverSession (CipherId cid) compression exts) = do+processServerHello cparams ctx (ServerHello rver serverRan serverSession (CipherId cid) compression shExts) = do -- A server which receives a legacy_version value not equal to -- 0x0303 MUST abort the handshake with an "illegal_parameter" -- alert.@@ -75,7 +75,7 @@ Error_Protocol (show rver ++ " is not supported") IllegalParameter -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx- sentExts <- tls13stSentExtensions <$> getTLS13State ctx+ chExts <- tls13stSentExtensions <$> getTLS13State ctx let clientCiphers = supportedCiphers $ ctxSupported ctx cipherAlg <- case findCipher cid clientCiphers of Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter@@ -92,26 +92,26 @@ -- if server returns extensions that we didn't request, fail. let checkExt (ExtensionRaw i _) | i == EID_Cookie = False -- for HRR- | otherwise = i `notElem` sentExts- when (any checkExt exts) $+ | otherwise = i `notElem` chExts+ when (any checkExt shExts) $ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension let isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do setTLS13HRR isHRR- when (not isHRR) $+ when isHRR $ setTLS13Cookie $ lookupAndDecode EID_Cookie MsgTServerHello- exts+ shExts Nothing (\cookie@(Cookie _) -> Just cookie) setVersion rver -- must be before processing supportedVersions ext- mapM_ processServerExtension exts+ mapM_ processServerExtension shExts - setALPN ctx MsgTServerHello exts+ setALPN ctx MsgTServerHello shExts ver <- usingState_ ctx getVersion @@ -149,6 +149,9 @@ then do -- Session is dummy in TLS 1.3. usingState_ ctx $ setSession serverSession+ processRecordSizeLimit ctx shExts True+ enableMyRecordLimit ctx+ enablePeerRecordLimit ctx updateContext13 ctx cipherAlg else do let resumingSession = case clientSessions cparams of@@ -159,7 +162,8 @@ usingState_ ctx $ do setSession serverSession setTLS12SessionResuming $ isJust resumingSession- updateContext12 ctx exts resumingSession+ processRecordSizeLimit ctx shExts False+ updateContext12 ctx shExts resumingSession processServerHello _ _ p = unexpected (show p) (Just "server hello") ----------------------------------------------------------------@@ -199,8 +203,8 @@ failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()-updateContext12 ctx exts resumingSession = do- ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello exts+updateContext12 ctx shExts resumingSession = do+ ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExts case resumingSession of Nothing -> return () Just sessionData -> do@@ -211,3 +215,27 @@ let mainSecret = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret)++----------------------------------------------------------------++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO ()+processRecordSizeLimit ctx shExts tls13 = do+ let mmylim = limitRecordSize $ ctxLimit ctx+ case mmylim of+ Nothing -> return ()+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ shExts+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ ack <- checkPeerRecordLimit ctx+ -- When a client sends RecordSizeLimit, it does not know+ -- which TLS version the server selects. RecordLimit is+ -- the length of plaintext. But RecordSizeLimit also+ -- includes CT: and padding for TLS 1.3. To convert+ -- RecordSizeLimit to RecordLimit, we should reduce the+ -- value by 1, which is the length of CT:.+ when (ack && tls13) $ setMyRecordLimit ctx $ Just (mylim - 1)
Network/TLS/Handshake/Client/TLS12.hs view
@@ -115,6 +115,7 @@ expectNewSessionTicket p = unexpected (show p) (Just "Handshake Finished") expectChangeCipher ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipher p = unexpected (show p) (Just "change cipher")
Network/TLS/Handshake/Client/TLS13.hs view
@@ -177,9 +177,17 @@ Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure -- Unused: -- caAlgs <- extalgs caextID uncertsig+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ exts+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas) usingHState ctx $ do setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)+ setTLS13CertComp zlib where -- setCertReqSigAlgsCert caAlgs @@ -203,7 +211,14 @@ -- not used in 0-RTT expectCertAndVerify :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()-expectCertAndVerify cparams ctx (Certificate13 _ (TLSCertificateChain cc) _) = do+expectCertAndVerify cparams ctx (Certificate13 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify cparams ctx (CompressedCertificate13 _ (TLSCertificateChain cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate")++processCertAndVerify+ :: MonadIO m+ => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m ()+processCertAndVerify cparams ctx cc = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc@@ -211,7 +226,6 @@ checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify ctx pubkey-expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate") ---------------------------------------------------------------- @@ -320,19 +334,23 @@ runPacketFlight ctx $ do case mcc of Nothing -> return ()- Just cc -> usingHState ctx getCertReqToken >>= loadClientData13 cc+ Just cc -> do+ reqtoken <- usingHState ctx getCertReqToken+ certComp <- usingHState ctx getTLS13CertComp+ loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey loadPacket13 ctx $ Handshake13 [rawFinished] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True} where- loadClientData13 chain (Just token) = do+ loadClientData13 chain (Just token) certComp = do let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ let certtag = if certComp then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [Certificate13 token (TLSCertificateChain chain) certExts]+ Handshake13 [certtag token (TLSCertificateChain chain) certExts] case certs of [] -> return () _ -> do@@ -343,7 +361,7 @@ vfy <- makeCertVerify ctx pubKey sigAlg hChSc loadPacket13 ctx $ Handshake13 [vfy] --- loadClientData13 _ _ =+ loadClientData13 _ _ _ = throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError @@ -361,7 +379,11 @@ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage- sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN)+ sendClientFlight13+ cparams+ ctx+ usedHash+ (ClientTrafficSecret applicationSecretN) postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol
Network/TLS/Handshake/Common.hs view
@@ -29,6 +29,8 @@ errorToAlertMessage, expectFinished, processCertificate,+ --+ setPeerRecordSizeLimit, ) where import Control.Concurrent.MVar@@ -139,6 +141,7 @@ sendCCSandFinished ctx role = do sendPacket12 ctx ChangeCipherSpec contextFlush ctx+ enablePeerRecordLimit ctx verifyData <- VerifyData <$> ( usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role@@ -308,7 +311,7 @@ processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion expected <-- VerifyData <$> (usingHState ctx $ getHandshakeDigest ver $ invertRole cc)+ VerifyData <$> usingHState ctx (getHandshakeDigest ver $ invertRole cc) when (expected /= verifyData) $ decryptError "cannot verify finished" usingState_ ctx $ setVerifyDataForRecv verifyData @@ -329,3 +332,29 @@ | ticket /= "" = Just $ B.copy ticket ticketOrSessionID12 _ (Session (Just sessionId)) = Just $ B.copy sessionId ticketOrSessionID12 _ _ = Nothing++setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()+setPeerRecordSizeLimit ctx tls13 (RecordSizeLimit n0) = do+ when (n0 < 64) $+ throwCore $+ Error_Protocol ("too small recode size limit: " ++ show n0) IllegalParameter++ -- RFC 8449 Section 4:+ -- Even if a larger record size limit is provided by a peer, an+ -- endpoint MUST NOT send records larger than the protocol-defined+ -- limit, unless explicitly allowed by a future TLS version or+ -- extension.+ let n1 = fromIntegral n0+ n2+ | n1 > protolim = protolim+ | otherwise = n1+ -- Even if peer's value is larger than the protocol-defined+ -- limitation, call "setPeerRecordLimit" to send+ -- "record_size_limit" as ACK. In this case, the protocol-defined+ -- limitation is used.+ let lim = if tls13 then n2 - 1 else n2+ setPeerRecordLimit ctx $ Just lim+ where+ protolim+ | tls13 = defaultRecordSizeLimit + 1+ | otherwise = defaultRecordSizeLimit
Network/TLS/Handshake/Common13.hs view
@@ -153,7 +153,7 @@ | role == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue- CertVerify13 <$> DigitallySigned hs <$> sign ctx pub hs target+ CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target checkCertVerify :: MonadIO m@@ -270,19 +270,27 @@ ---------------------------------------------------------------- -makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13-makeCertRequest sparams ctx certReqCtx =- let sigAlgs =- extensionEncode $- SignatureAlgorithms $- supportedHashSignatures $- ctxSupported ctx+makeCertRequest+ :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13+makeCertRequest sparams ctx certReqCtx zlib =+ let sigAlgs = SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx+ signatureAlgExt = Just $ toExtensionRaw sigAlgs++ compCertExt+ | zlib = Just $ toExtensionRaw $ CompressCertificate [CCA_Zlib]+ | otherwise = Nothing+ caDns = map extractCAname $ serverCACertificates sparams- caDnsEncoded = extensionEncode $ CertificateAuthorities caDns- caExtension- | null caDns = []- | otherwise = [ExtensionRaw EID_CertificateAuthorities caDnsEncoded]- crexts = ExtensionRaw EID_SignatureAlgorithms sigAlgs : caExtension+ caExt+ | null caDns = Nothing+ | otherwise = Just $ toExtensionRaw $ CertificateAuthorities caDns++ crexts =+ catMaybes+ [ {- 0x0d -} signatureAlgExt+ , {- 0x1b -} compCertExt+ , {- 0x2f -} caExt+ ] in CertRequest13 certReqCtx crexts ----------------------------------------------------------------@@ -424,7 +432,14 @@ case epkt of Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h : hs)) -> found h hs- Right ChangeCipherSpec13 -> recvLoop+ Right ChangeCipherSpec13 -> do+ alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv+ if alreadyReceived+ then+ liftIO $ throwCore $ Error_Protocol "multiple CSS in TLS 1.3" UnexpectedMessage+ else do+ liftIO $ usingHState ctx $ setCCS13Recv True+ recvLoop Right (Alert13 _) -> throwCore Error_TCP_Terminate Right x -> unexpected (show x) (Just "handshake 13") Left err -> throwCore err@@ -446,6 +461,9 @@ in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13++{- isHashSignatureValid13 (HashIntrinsic, s) = s `elem` [ SignatureRSApssRSAeSHA256@@ -460,6 +478,7 @@ isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False+-} ----------------------------------------------------------------
Network/TLS/Handshake/Process.hs view
@@ -9,11 +9,10 @@ import Control.Concurrent.MVar import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Sending import Network.TLS.Struct import Network.TLS.Struct13
Network/TLS/Handshake/Random.hs view
@@ -3,8 +3,6 @@ module Network.TLS.Handshake.Random ( serverRandom, clientRandom,- hrrRandom,- isHelloRetryRequest, isDowngraded, ) where @@ -57,44 +55,3 @@ clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32--hrrRandom :: ServerRandom-hrrRandom =- ServerRandom $- B.pack- [ 0xCF- , 0x21- , 0xAD- , 0x74- , 0xE5- , 0x9A- , 0x61- , 0x11- , 0xBE- , 0x1D- , 0x8C- , 0x02- , 0x1E- , 0x65- , 0xB8- , 0x91- , 0xC2- , 0xA2- , 0x11- , 0x16- , 0x7A- , 0xBB- , 0x8C- , 0x5E- , 0x07- , 0x9E- , 0x09- , 0xE2- , 0xC8- , 0xA8- , 0x33- , 0x9C- ]--isHelloRetryRequest :: ServerRandom -> Bool-isHelloRetryRequest = (== hrrRandom)
Network/TLS/Handshake/Server.hs view
@@ -61,6 +61,8 @@ case mClientKeyShare of Nothing -> do sendHRR ctx r0 ch+ -- Don't reset ctxEstablished since 0-RTT data+ -- would be comming, which should be ignored. handshakeServer sparams ctx Just cliKeyShare -> do r1 <-@@ -83,7 +85,7 @@ let ok = tls13 && supportsPHA when ok $ do certReqCtx <- newCertReqContext ctx- let certReq = makeCertRequest sparams ctx certReqCtx+ let certReq = makeCertRequest sparams ctx certReqCtx False bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do addCertRequest13 ctx certReq sendPacket13 ctx $ Handshake13 [certReq]
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -84,8 +84,9 @@ where availableCiphers = getCiphers ciphers creds sigCreds + p = makeCredentialPredicate TLS12 chExtensions allCreds =- filterCredentials (isCredentialAllowed TLS12 chExtensions) $+ filterCredentials (isCredentialAllowed TLS12 p) $ extraCreds `mappend` sharedCredentials (serverShared sparams) -- When selecting a cipher we must ensure that it is allowed for the
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -11,7 +11,6 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO@@ -49,11 +48,16 @@ chExtensions False (\(EarlyDataIndication _) -> True)- when rtt0 $- -- mark a 0-RTT attempt before a possible HRR, and before updating the- -- status again if 0-RTT successful- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding- -- Deciding key exchange from key shares+ if rtt0+ then+ -- mark a 0-RTT attempt before a possible HRR, and before updating the+ -- status again if 0-RTT successful+ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ else+ -- In the case of HRR, EarlyDataNotAllowed is already set.+ -- It should be cleared here.+ setEstablished ctx NotEstablished+ -- Deciding key exchange from key shares let require = throwCore $ Error_Protocol@@ -108,12 +112,9 @@ throwCore $ Error_Protocol "no group in common with the client for HRR" HandshakeFailure g : _ -> do- let serverKeyShare = extensionEncode $ KeyShareHRR g- selectedVersion = extensionEncode $ SupportedVersionsServerHello TLS13- extensions =- [ ExtensionRaw EID_KeyShare serverKeyShare- , ExtensionRaw EID_SupportedVersions selectedVersion- ]+ let keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ extensions = [keyShareExt, versionExt] hrr = ServerHello13 hrrRandom chSession (CipherId $ cipherID usedCipher) extensions usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest runPacketFlight ctx $ do
Network/TLS/Handshake/Server/Common.hs view
@@ -7,9 +7,11 @@ credentialDigitalSignatureKey, filterCredentials, filterCredentialsWithHashSignatures,+ makeCredentialPredicate, isCredentialAllowed, storePrivInfoServer, hashAndSignaturesInCommon,+ processRecordSizeLimit, ) where import Control.Monad.State.Strict@@ -51,23 +53,25 @@ filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials filterCredentials p (Credentials l) = Credentials (filter p l) -isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool-isCredentialAllowed ver exts cred =+-- ECDSA keys are tested against supported elliptic curves until TLS12 but+-- not after. With TLS13, the curve is linked to the signature algorithm+-- and client support is tested with signatureCompatible13.+makeCredentialPredicate :: Version -> [ExtensionRaw] -> (Group -> Bool)+makeCredentialPredicate ver exts+ | ver >= TLS13 = const True+ | otherwise =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ exts+ (const True)+ (\(SupportedGroups sg) -> (`elem` sg))++isCredentialAllowed :: Version -> (Group -> Bool) -> Credential -> Bool+isCredentialAllowed ver p cred = pubkey `versionCompatible` ver && satisfiesEcPredicate p pubkey where (pubkey, _) = credentialPublicPrivateKeys cred- -- ECDSA keys are tested against supported elliptic curves until TLS12 but- -- not after. With TLS13, the curve is linked to the signature algorithm- -- and client support is tested with signatureCompatible13.- p- | ver < TLS13 =- lookupAndDecode- EID_SupportedGroups- MsgTClientHello- exts- (const True)- (\(SupportedGroups sg) -> (`elem` sg))- | otherwise = const True -- Filters a list of candidate credentials with credentialMatchesHashSignatures. --@@ -131,11 +135,8 @@ usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto- return $- Just $- ExtensionRaw- EID_ApplicationLayerProtocolNegotiation- (extensionEncode $ ApplicationLayerProtocolNegotiation [proto])+ let alpn = ApplicationLayerProtocolNegotiation [proto]+ return $ Just $ toExtensionRaw alpn clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do@@ -180,3 +181,25 @@ exts defVal (\(SignatureAlgorithms sas) -> sas)++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)+processRecordSizeLimit ctx chExts tls13 = do+ let mmylim = limitRecordSize $ ctxLimit ctx+ setMyRecordLimit ctx mmylim+ case mmylim of+ Nothing -> return Nothing+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ chExts+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ peerSentRSL <- checkPeerRecordLimit ctx+ if peerSentRSL+ then do+ let mysiz = fromIntegral mylim + if tls13 then 1 else 0+ rsl = RecordSizeLimit mysiz+ return $ Just $ toExtensionRaw rsl+ else return Nothing
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -111,7 +111,7 @@ -> Maybe Credential -> [ExtensionRaw] -> IO ([Handshake] -> [Handshake])-sendServerFirstFlight sparams ctx usedCipher mcred chExts = do+sendServerFirstFlight ServerParams{..} ctx usedCipher mcred chExts = do let b0 = id let cc = case mcred of Just (srvCerts, _) -> srvCerts@@ -138,26 +138,28 @@ -- -- Client certificates MUST NOT be accepted if not requested. --- if serverWantClientCert sparams+ if serverWantClientCert then do let (certTypes, hashSigs) =- let as = supportedHashSignatures $ ctxSupported ctx+ let as = supportedHashSignatures serverSupported in (nub $ mapMaybe hashSigToCertType as, as) creq = CertRequest certTypes hashSigs- (map extractCAname $ serverCACertificates sparams)+ (map extractCAname serverCACertificates) usingHState ctx $ setCertReqSent True return $ b2 . (creq :) else return b2 where+ commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts+ commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts setup_DHE = do- let possibleFFGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableFFGroups+ let possibleFFGroups = commonGroups `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] ->- let dhparams = fromJust $ serverDHEParams sparams+ let dhparams = fromJust serverDHEParams in case findFiniteFieldGroup dhparams of Just g -> do usingHState ctx $ setSupportedGroup g@@ -182,8 +184,7 @@ -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do- let hashSigs = hashAndSignaturesInCommon (supportedHashSignatures $ ctxSupported ctx) chExts- case filter (pubKey `signatureCompatible`) hashSigs of+ case filter (pubKey `signatureCompatible`) commonHashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x : _ -> return x @@ -209,7 +210,7 @@ return serverParams generateSKX_ECDHE kxsAlg = do- let possibleECGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableECGroups+ let possibleECGroups = commonGroups `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure g : _ -> return g@@ -243,24 +244,6 @@ case mcred of Just cred -> storePrivInfoServer ctx cred _ -> return () -- return a sensible error-- -- in TLS12, we need to check as well the certificates we are sending if they have in the extension- -- the necessary bits set.- secReneg <- usingState_ ctx getSecureRenegotiation- secRengExt <-- if secReneg- then do- vd <- usingState_ ctx $ do- VerifyData cvd <- getVerifyData ClientRole- VerifyData svd <- getVerifyData ServerRole- return $ SecureRenegotiation cvd svd- return $ Just $ toExtensionRaw vd- else return Nothing- ems <- usingHState ctx getExtendedMainSecret- let emsExt- | ems = Just $ toExtensionRaw ExtendedMainSecret- | otherwise = Nothing- protoExt <- applicationProtocol ctx chExts sparams sniExt <- do if resuming then return Nothing@@ -273,22 +256,48 @@ -- field of this extension SHALL be empty. Just _ -> return $ Just $ toExtensionRaw $ ServerName [] Nothing -> return Nothing++ let ecPointExt = case extensionLookup EID_EcPointFormats chExts of+ Nothing -> Nothing+ Just _ -> Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]++ alpnExt <- applicationProtocol ctx chExts sparams++ ems <- usingHState ctx getExtendedMainSecret+ let emsExt+ | ems = Just $ toExtensionRaw ExtendedMainSecret+ | otherwise = Nothing+ let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams- ticktExt+ sessionTicketExt | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket "" | otherwise = Nothing- let eccExt = case extensionLookup EID_EcPointFormats chExts of- Nothing -> Nothing- Just _ -> Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]++ -- in TLS12, we need to check as well the certificates we are sending if they have in the extension+ -- the necessary bits set.+ secReneg <- usingState_ ctx getSecureRenegotiation+ secureRenegExt <-+ if secReneg+ then do+ vd <- usingState_ ctx $ do+ VerifyData cvd <- getVerifyData ClientRole+ VerifyData svd <- getVerifyData ServerRole+ return $ SecureRenegotiation cvd svd+ return $ Just $ toExtensionRaw vd+ else return Nothing++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExts False+ let shExts = sharedHelloExtensions (serverShared sparams) ++ catMaybes- [ secRengExt- , emsExt- , protoExt- , sniExt- , ticktExt- , eccExt+ [ {- 0x00 -} sniExt+ , {- 0x0b -} ecPointExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0xff01 -} secureRenegExt ] usingState_ ctx $ setVersion TLS12 usingHState ctx $@@ -302,8 +311,8 @@ (compressionID nullCompression) shExts -negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]-negotiatedGroupsInCommon ctx chExts =+negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]+negotiatedGroupsInCommon serverGroups chExts = lookupAndDecode EID_SupportedGroups MsgTClientHello@@ -311,5 +320,4 @@ [] common where- serverGroups = supportedGroups (ctxSupported ctx) common (SupportedGroups clientGroups) = serverGroups `intersect` clientGroups
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -45,13 +45,25 @@ , Bool ) sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do+ -- parse CompressCertificate to check if it is broken here+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ chExtensions+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas)++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExtensions True+ enableMyRecordLimit ctx+ newSession ctx >>= \ss -> usingState_ ctx $ do setSession ss setTLS13ClientSupportsPHA supportsPHA usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare srand <- setServerParameter -- ALPN is used in choosePSK- protoExt <- applicationProtocol ctx chExtensions sparams+ alpnExt <- applicationProtocol ctx chExtensions sparams (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) True let earlySecret = pairBase earlyKey@@ -62,8 +74,9 @@ rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)- let allCreds =- filterCredentials (isCredentialAllowed TLS13 chExtensions) $+ let p = makeCredentialPredicate TLS13 chExtensions+ allCreds =+ filterCredentials (isCredentialAllowed TLS13 p) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx@@ -101,10 +114,11 @@ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo ----------------------------------------------------------------- sendExtensions rtt0OK protoExt+ liftIO $ enablePeerRecordLimit ctx+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt case mCredInfo of Nothing -> return ()- Just (cred, hashSig) -> sendCertAndVerify cred hashSig+ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs loadPacket13 ctx $ Handshake13 [rawFinished]@@ -118,11 +132,7 @@ let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0, serverApplicationSecret0) contextSync ctx $ SendServerFinished appSecInfo ----------------------------------------------------------------- if rtt0OK- then setEstablished ctx (EarlyDataAllowed rtt0max)- else- when (established == NotEstablished) $- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max) return (appKey, clientHandshakeSecret, authenticated, rtt0OK) where choice = makeCipherChoice TLS13 usedCipher@@ -230,59 +240,62 @@ mcs -> return mcs sendServerHello keyShare srand extensions = do- let extensions' =- toExtensionRaw (KeyShareServerHello keyShare)- : toExtensionRaw (SupportedVersionsServerHello TLS13)- : extensions+ let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ extensions' = keyShareExt : versionExt : extensions helo = ServerHello13 srand chSession (CipherId (cipherID usedCipher)) extensions' loadPacket13 ctx $ Handshake13 [helo] - sendCertAndVerify cred@(certChain, _) hashSig = do+ sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here.- certReq = makeCertRequest sparams ctx certReqCtx+ certReq = makeCertRequest sparams ctx certReqCtx True loadPacket13 ctx $ Handshake13 [certReq] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) []+ let certtag = if zlib then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [Certificate13 "" (TLSCertificateChain certChain) ess]+ Handshake13 [certtag "" (TLSCertificateChain certChain) ess] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc loadPacket13 ctx $ Handshake13 [vrfy] - sendExtensions rtt0OK protoExt = do+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI- let sniExtension = case msni of+ let sniExt = 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 _ -> Just $ toExtensionRaw $ ServerName [] Nothing -> Nothing+ mgroup <- usingHState ctx getSupportedGroup let serverGroups = supportedGroups (ctxSupported ctx)- groupExtension = case serverGroups of+ groupExt = case serverGroups of [] -> Nothing rg : _ -> case mgroup of Nothing -> Nothing Just grp | grp == rg -> Nothing | otherwise -> Just $ toExtensionRaw $ SupportedGroups serverGroups- let earlyDataExtension+ let earlyDataExt | rtt0OK = Just $ toExtensionRaw $ EarlyDataIndication Nothing | otherwise = Nothing+ let extensions = sharedHelloExtensions (serverShared sparams) ++ catMaybes- [ earlyDataExtension- , groupExtension- , sniExtension- , protoExt+ [ {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x10 -} alpnExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x2a -} earlyDataExt ] extensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions
Network/TLS/Handshake/Server/TLS12.hs view
@@ -122,6 +122,7 @@ expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO) expectChangeCipherSpec ctx ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipherSpec _ p = unexpected (show p) (Just "change cipher")
Network/TLS/Handshake/Server/TLS13.hs view
@@ -45,8 +45,8 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do- skip <- recvHandshake13 ctx $ expectCertificate sparams ctx- unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)+ recvHandshake13 ctx $ expectCertificate sparams ctx+ recvHandshake13hash ctx (expectCertVerify sparams ctx) recvHandshake13hash ctx expectFinished' ensureRecvComplete ctx else@@ -94,14 +94,19 @@ expectEndOfEarlyData _ _ hs = unexpected (show hs) (Just "end of early data") expectCertificate- :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool+ :: MonadIO m => ServerParams -> Context -> Handshake13 -> m () expectCertificate sparams ctx (Certificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs- return $ isNullCertificateChain certs+expectCertificate sparams ctx (CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do+ when (certCtx /= "") $+ throwCore $+ Error_Protocol "certificate request context MUST be empty" IllegalParameter+ -- fixme checking _ext+ clientCertificate sparams ctx certs expectCertificate _ _ hs = unexpected (show hs) (Just "certificate 13") sendNewSessionTicket@@ -144,8 +149,8 @@ createNewSessionTicket life add nonce identity maxSize = NewSessionTicket13 life add nonce identity extensions where- tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize- extensions = [ExtensionRaw EID_EarlyData tedi]+ earlyDataExt = toExtensionRaw $ EarlyDataIndication $ Just $ fromIntegral maxSize+ extensions = [earlyDataExt] adjustLifetime i | i < 0 = 0 | i > 604800 = 604800@@ -155,7 +160,7 @@ :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () expectCertVerify sparams ctx hChCc (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <-- checkValidClientCertChain ctx "finished 13 message expected"+ checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure c : _ -> return $ certPubKey $ getCertificate c@@ -192,7 +197,22 @@ else decryptError "verification failed" postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx (TLSCertificateChain certs) _ext) = do+postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h+postHandshakeAuthServerWith sparams ctx h@(CompressedCertificate13 certCtx (TLSCertificateChain certs) _ext) = processHandshakeAuthServerWith sparams ctx certCtx certs h+postHandshakeAuthServerWith _ _ _ =+ throwCore $+ Error_Protocol+ "unexpected handshake message received in postHandshakeAuthServerWith"+ UnexpectedMessage++processHandshakeAuthServerWith+ :: ServerParams+ -> Context+ -> CertReqContext+ -> CertificateChain+ -> Handshake13+ -> IO ()+processHandshakeAuthServerWith sparams ctx certCtx certs h = do mCertReq <- getCertRequest13 ctx certCtx when (isNothing mCertReq) $ throwCore $@@ -229,8 +249,3 @@ [ PendingRecvActionHash False (expectCertVerify sparams ctx) , PendingRecvActionHash False expectFinished' ]-postHandshakeAuthServerWith _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in postHandshakeAuthServerWith"- UnexpectedMessage
Network/TLS/Handshake/State.hs view
@@ -67,8 +67,12 @@ getTLS13EarlySecret, setTLS13ResumptionSecret, getTLS13ResumptionSecret,+ setTLS13CertComp,+ getTLS13CertComp, setCCS13Sent, getCCS13Sent,+ setCCS13Recv,+ getCCS13Recv, ) where import Control.Monad.State.Strict@@ -133,7 +137,9 @@ , hstTLS13RTT0Status :: RTT0Status , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret)+ , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool+ , hstCCS13Recv :: Bool } deriving (Show) @@ -224,7 +230,9 @@ , hstTLS13RTT0Status = RTT0None , hstTLS13EarlySecret = Nothing , hstTLS13ResumptionSecret = Nothing+ , hstTLS13CertComp = False , hstCCS13Sent = False+ , hstCCS13Recv = False } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState)@@ -326,11 +334,23 @@ getTLS13ResumptionSecret :: HandshakeM (Maybe (BaseSecret ResumptionSecret)) getTLS13ResumptionSecret = gets hstTLS13ResumptionSecret +setTLS13CertComp :: Bool -> HandshakeM ()+setTLS13CertComp comp = modify (\hst -> hst{hstTLS13CertComp = comp})++getTLS13CertComp :: HandshakeM Bool+getTLS13CertComp = gets hstTLS13CertComp+ setCCS13Sent :: Bool -> HandshakeM () setCCS13Sent sent = modify (\hst -> hst{hstCCS13Sent = sent}) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent++setCCS13Recv :: Bool -> HandshakeM ()+setCCS13Recv sent = modify (\hst -> hst{hstCCS13Recv = sent})++getCCS13Recv :: HandshakeM Bool+getCCS13Recv = gets hstCCS13Recv setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst{hstCertReqSent = b})
Network/TLS/HashAndSignature.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} module Network.TLS.HashAndSignature (@@ -25,10 +26,14 @@ SignatureEd448, SignatureRSApsspssSHA256, SignatureRSApsspssSHA384,- SignatureRSApsspssSHA512+ SignatureRSApsspssSHA512,+ SignatureBrainpoolP256,+ SignatureBrainpoolP384,+ SignatureBrainpoolP512 ), HashAndSignatureAlgorithm, supportedSignatureSchemes,+ signatureSchemesForTLS13, ) where import Network.TLS.Imports@@ -99,6 +104,12 @@ pattern SignatureRSApsspssSHA384 = SignatureAlgorithm 10 pattern SignatureRSApsspssSHA512 :: SignatureAlgorithm pattern SignatureRSApsspssSHA512 = SignatureAlgorithm 11+pattern SignatureBrainpoolP256 :: SignatureAlgorithm -- RFC8734+pattern SignatureBrainpoolP256 = SignatureAlgorithm 26+pattern SignatureBrainpoolP384 :: SignatureAlgorithm+pattern SignatureBrainpoolP384 = SignatureAlgorithm 27+pattern SignatureBrainpoolP512 :: SignatureAlgorithm+pattern SignatureBrainpoolP512 = SignatureAlgorithm 28 instance Show SignatureAlgorithm where show SignatureAnonymous = "Anonymous"@@ -113,6 +124,9 @@ show SignatureRSApsspssSHA256 = "RSApsspssSHA256" show SignatureRSApsspssSHA384 = "RSApsspssSHA384" show SignatureRSApsspssSHA512 = "RSApsspssSHA512"+ show SignatureBrainpoolP256 = "BrainpoolP256"+ show SignatureBrainpoolP384 = "BrainpoolP384"+ show SignatureBrainpoolP512 = "BrainpoolP512" show (SignatureAlgorithm x) = "Signature " ++ show x {- FOURMOLU_ENABLE -} @@ -120,6 +134,10 @@ type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) +instance {-# OVERLAPS #-} Show (HashAlgorithm, SignatureAlgorithm) where+ show (HashIntrinsic, s) = show s+ show (h, s) = show h ++ "-" ++ show s+ {- FOURMOLU_DISABLE -} supportedSignatureSchemes :: [HashAndSignatureAlgorithm] supportedSignatureSchemes =@@ -127,13 +145,17 @@ [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) -- ECDSA algorithms- , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)+ , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603) , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503)- , (HashSHA512, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)- -- RSASSA-PSS algorithms with public key OID RSASSA-PSS- , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_pss_sha512(0x080b)- , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_pss_sha384(0x080a)- , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_pss_sha256(0x0809)+ , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)+ -- RSASSA-PSS RSAE algorithms+ , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)+ , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)+ , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)+ -- RSASSA-PSS PSS algorithms with+ , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b)+ , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a)+ , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809) -- RSASSA-PKCS1-v1_5 algorithms , (HashSHA512, SignatureRSA) -- rsa_pkcs1_sha512(0x0601) , (HashSHA384, SignatureRSA) -- rsa_pkcs1_sha384(0x0501)@@ -141,5 +163,24 @@ -- Legacy algorithms , (HashSHA1, SignatureRSA) -- rsa_pkcs1_sha1 (0x0201) , (HashSHA1, SignatureECDSA) -- ecdsa_sha1 (0x0203)+ ]++signatureSchemesForTLS13 :: [(HashAlgorithm, SignatureAlgorithm)]+signatureSchemesForTLS13 =+ -- EdDSA algorithms+ [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808)+ , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807)+ -- ECDSA algorithms+ , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603)+ , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503)+ , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)+ -- RSASSA-PSS RSAE algorithms+ , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)+ , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)+ , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)+ -- RSASSA-PSS PSS algorithms with+ , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b)+ , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a)+ , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809) ] {- FOURMOLU_ENABLE -}
Network/TLS/IO.hs view
@@ -24,10 +24,10 @@ import Network.TLS.Context.Internal import Network.TLS.Hooks+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Receiving import Network.TLS.Record-import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -85,35 +85,44 @@ -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket12 :: Context -> IO (Either TLSError Packet)-recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = do- 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 <- recordRecv recordLayer ctx appDataOverhead- case erecord of- Left err -> return $ Left err- Right record ->- if hrr && isCCS record- then recvPacket12 ctx- else do- pktRecv <- processPacket ctx record+recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ ctxLimit ctx+ loop count+ | count > lim = do+ let err = Error_Packet "too many handshake fragment"+ logPacket ctx $ show err+ return $ Left err+ loop count = do+ hrr <- usingState_ ctx getTLS13HRR+ erecord <- recordRecv12 recordLayer ctx+ case erecord of+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ Right record+ | hrr && isCCS record -> loop (count + 1)+ | otherwise -> do+ pktRecv <- decodePacket12 ctx record if isEmptyHandshake pktRecv- then -- When a handshake record is fragmented we continue- -- receiving in order to feed stHandshakeRecordCont- recvPacket12 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 ()- return pkt+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented+ -- we continue receiving in order to feed+ -- stHandshakeRecordCont+ loop (count + 1)+ else case pktRecv of+ Right (Handshake hss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->+ Right . Handshake <$> mapM (hookRecvHandshake hooks) hss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True@@ -123,39 +132,57 @@ isEmptyHandshake (Right (Handshake [])) = True isEmptyHandshake _ = False +logPacket :: Context -> String -> IO ()+logPacket ctx msg = withLog ctx $ \logging -> loggingPacketRecv logging msg+ ---------------------------------------------------------------- recvPacket13 :: Context -> IO (Either TLSError Packet13)-recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do- erecord <- recordRecv13 recordLayer ctx- case erecord of- Left err@(Error_Protocol _ BadRecordMac) -> do- -- If the server decides to reject RTT0 data but accepts RTT1- -- data, the server should skip all records for RTT0 data.- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacket13 ctx- _ -> return $ Left err- Left err -> return $ Left err- Right record -> do- 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+recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ ctxLimit ctx+ loop count+ | count > lim =+ return $ Left $ Error_Packet "too many handshake fragment"+ loop count = do+ erecord <- recordRecv13 recordLayer ctx+ case erecord of+ Left err@(Error_Protocol _ BadRecordMac) -> do+ -- If the server decides to reject RTT0 data but accepts RTT1+ -- data, the server should skip all records for RTT0 data.+ logPacket ctx $ show err+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed n+ | n > 0 -> do+ setEstablished ctx $ EarlyDataNotAllowed (n - 1)+ loop (count + 1)+ _ -> return $ Left err+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ Right record -> do+ pktRecv <- decodePacket13 ctx record+ if isEmptyHandshake13 pktRecv+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented we+ -- continue receiving in order to feed+ -- stHandshakeRecordCont13+ loop (count + 1)+ else do+ case pktRecv of+ Right (Handshake13 hss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->+ Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool isEmptyHandshake13 (Right (Handshake13 [])) = True
+ Network/TLS/IO/Decode.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.IO.Decode (+ decodePacket12,+ decodePacket13,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.ErrT+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Util+import Network.TLS.Wire++decodePacket12 :: Context -> Record Plaintext -> IO (Either TLSError Packet)+decodePacket12 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment+decodePacket12 _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment))+decodePacket12 ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left err -> return $ Left err+ Right _ -> do+ switchRxEncryption ctx+ return $ Right ChangeCipherSpec+decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do+ keyxchg <-+ getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)+ usingState ctx $ do+ let currentParams =+ CurrentParams+ { cParamsVersion = ver+ , cParamsKeyXchgType = keyxchg+ }+ -- get back the optional continuation, and parse as many handshake record as possible.+ mCont <- gets stHandshakeRecordCont+ modify (\st -> st{stHandshakeRecordCont = Nothing})+ hss <- parseMany currentParams mCont (fragmentGetBytes fragment)+ return $ Handshake hss+ where+ parseMany currentParams mCont bs =+ case fromMaybe decodeHandshakeRecord mCont bs of+ GotError err -> throwError err+ GotPartial cont ->+ modify (\st -> st{stHandshakeRecordCont = Just cont}) >> return []+ GotSuccess (ty, content) ->+ either throwError (return . (: [])) $ decodeHandshake currentParams ty content+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right hh -> (hh :) <$> parseMany currentParams Nothing left+decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")++switchRxEncryption :: Context -> IO ()+switchRxEncryption ctx =+ usingHState ctx (gets hstPendingRxState) >>= \rx ->+ modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)++----------------------------------------------------------------++decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)+decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left err -> return $ Left err+ Right _ -> return $ Right ChangeCipherSpec13+decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment+decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))+decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do+ mCont <- gets stHandshakeRecordCont13+ modify (\st -> st{stHandshakeRecordCont13 = Nothing})+ hss <- parseMany mCont (fragmentGetBytes fragment)+ return $ Handshake13 hss+ where+ parseMany mCont bs =+ case fromMaybe decodeHandshakeRecord13 mCont bs of+ GotError err -> throwError err+ GotPartial cont ->+ modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []+ GotSuccess (ty, content) ->+ either throwError (return . (: [])) $ decodeHandshake13 ty content+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right hh -> (hh :) <$> parseMany Nothing left+decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
+ Network/TLS/IO/Encode.hs view
@@ -0,0 +1,123 @@+module Network.TLS.IO.Encode (+ encodePacket12,+ encodePacket13,+ updateHandshake12,+ updateHandshake13,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B+import Data.IORef++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Parameters+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types (Role (..))+import Network.TLS.Util++-- | encodePacket transform a packet into marshalled data related to current state+-- and updating state on the go+encodePacket12+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet+ -> IO (Either TLSError bytes)+encodePacket12 ctx recordLayer pkt = do+ (ver, _) <- decideRecordVersion ctx+ let pt = packetType pkt+ mkRecord bs = Record pt ver (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments12 ctx mlen pkt+ bs <- fmap mconcat <$> forEitherM records (recordEncode12 recordLayer ctx)+ when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx+ return bs++-- 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.+packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]+packetToFragments12 ctx mlen (Handshake hss) =+ getChunks mlen . B.concat <$> mapM (updateHandshake12 ctx) hss+packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]+packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]+packetToFragments12 _ _ (AppData x) = return [x]++switchTxEncryption :: Context -> IO ()+switchTxEncryption ctx = do+ tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)+ (ver, role) <- usingState_ ctx $ do+ v <- getVersion+ r <- getRole+ return (v, r)+ liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)+ -- set empty packet counter measure if condition are met+ when+ ( ver <= TLS10+ && role == ClientRole+ && isCBC tx+ && supportedEmptyPacket (ctxSupported ctx)+ )+ $ liftIO+ $ writeIORef (ctxNeedEmptyPacket ctx) True+ where+ isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)++updateHandshake12 :: Context -> Handshake -> IO ByteString+updateHandshake12 ctx hs = do+ usingHState ctx $ do+ when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded+ when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded+ return encoded+ where+ encoded = encodeHandshake hs++----------------------------------------------------------------++encodePacket13+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet13+ -> IO (Either TLSError bytes)+encodePacket13 ctx recordLayer pkt = do+ let pt = contentType pkt+ mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments13 ctx mlen pkt+ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)++packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]+packetToFragments13 ctx mlen (Handshake13 hss) =+ getChunks mlen . B.concat <$> mapM (updateHandshake13 ctx) hss+packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]+packetToFragments13 _ _ (AppData13 x) = return [x]+packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]++updateHandshake13 :: Context -> Handshake13 -> IO ByteString+updateHandshake13 ctx hs+ | isIgnored hs = return encoded+ | otherwise = usingHState ctx $ do+ when (isHRR hs) wrapAsMessageHash13+ updateHandshakeDigest encoded+ addHandshakeMessage encoded+ return encoded+ where+ encoded = encodeHandshake13 hs++ isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand+ isHRR _ = False++ isIgnored NewSessionTicket13{} = True+ isIgnored KeyUpdate13{} = True+ isIgnored _ = False
Network/TLS/Internal.hs view
@@ -2,14 +2,15 @@ module Network.TLS.Internal ( module Network.TLS.Extension,+ module Network.TLS.IO.Decode,+ module Network.TLS.IO.Encode, module Network.TLS.Packet, module Network.TLS.Packet13,- module Network.TLS.Receiving,- module Network.TLS.Sending, module Network.TLS.Struct, module Network.TLS.Struct13, module Network.TLS.Types, module Network.TLS.Wire,+ module Network.TLS.X509, sendPacket12, recvPacket12, makeCipherShowPretty,@@ -20,14 +21,15 @@ import Network.TLS.Core (recvPacket12, sendPacket12) import Network.TLS.Extension import Network.TLS.Extra.Cipher+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Packet import Network.TLS.Packet13-import Network.TLS.Receiving-import Network.TLS.Sending import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire+import Network.TLS.X509 hiding (Certificate) ----------------------------------------------------------------
Network/TLS/Packet.hs view
@@ -75,6 +75,9 @@ import Network.TLS.Util.ASN1 import Network.TLS.Wire +----------------------------------------------------------------+-- Header+ data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version@@ -83,7 +86,7 @@ } deriving (Show, Eq) -{- marshall helpers -}+-- marshall helpers getBinaryVersion :: Get Version getBinaryVersion = Version <$> getWord16 @@ -99,9 +102,7 @@ getHandshakeType :: Get HandshakeType getHandshakeType = HandshakeType <$> getWord8 -{-- - decode and encode headers- -}+-- decode and encode headers decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getBinaryVersion <*> getWord16@@ -109,11 +110,24 @@ encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) -{- FIXME check len <= 2^14 -}+-- FIXME check len <= 2^14 -{-- - decode and encode ALERT- -}+------------------------------------------------------------+-- CCS++decodeChangeCipherSpec :: ByteString -> Either TLSError ()+decodeChangeCipherSpec = runGetErr "changecipherspec" $ do+ x <- getWord8+ when (x /= 1) $ fail "unknown change cipher spec content"+ len <- remaining+ when (len /= 0) $ fail "the length of CSS must be 1"++encodeChangeCipherSpec :: ByteString+encodeChangeCipherSpec = runPut (putWord8 1)++----------------------------------------------------------------+-- Alert+ decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- AlertLevel <$> getWord8@@ -134,7 +148,9 @@ where encodeAlert (al, ad) = putWord8 (fromAlertLevel al) >> putWord8 (fromAlertDescription ad) -{- decode and encode HANDSHAKE -}+----------------------------------------------------------------+-- decode HANDSHAKE+ decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType@@ -148,6 +164,7 @@ HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello HandshakeType_ServerHello -> decodeServerHello+ HandshakeType_NewSessionTicket -> decodeNewSessionTicket HandshakeType_Certificate -> decodeCertificate HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp HandshakeType_CertRequest -> decodeCertRequest cp@@ -155,7 +172,6 @@ HandshakeType_CertVerify -> decodeCertVerify cp HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp HandshakeType_Finished -> decodeFinished- HandshakeType_NewSessionTicket -> decodeNewSessionTicket x -> fail $ "Unsupported HandshakeType " ++ show x {- FOURMOLU_ENABLE -} @@ -172,7 +188,7 @@ r <- remaining exts <- if r > 0- then fromIntegral <$> getWord16 >>= getExtensions+ then getWord16 >>= getExtensions . fromIntegral else return [] r1 <- remaining when (r1 /= 0) $ fail "Client hello"@@ -189,12 +205,12 @@ r <- remaining exts <- if r > 0- then fromIntegral <$> getWord16 >>= getExtensions+ then getWord16 >>= getExtensions . fromIntegral else return [] return $ ServerHello ver random session cipherid compressionid exts -decodeServerHelloDone :: Get Handshake-decodeServerHelloDone = return ServerHelloDone+decodeNewSessionTicket :: Get Handshake+decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16 decodeCertificate :: Get Handshake decodeCertificate = do@@ -207,67 +223,13 @@ where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) -decodeFinished :: Get Handshake-decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes)--decodeNewSessionTicket :: Get Handshake-decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16--decodeCertRequest :: CurrentParams -> Get Handshake-decodeCertRequest _cp = do- certTypes <- map CertificateType <$> getWords8- sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms- CertRequest certTypes sigHashAlgs <$> getDNames- where- getSignatureHashAlgorithms len =- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))---- | Decode a list CA distinguished names-getDNames :: Get [DistinguishedName]-getDNames = do- dNameLen <- getWord16- -- FIXME: Decide whether to remove this check completely or to make it an option.- -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"- getList (fromIntegral dNameLen) getDName- where- getDName = do- dName <- getOpaque16- when (B.length dName == 0) $ fail "certrequest: invalid DN length"- dn <-- either fail return $ decodeASN1Object "cert request DistinguishedName" dName- return (2 + B.length dName, dn)--decodeCertVerify :: CurrentParams -> Get Handshake-decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)+---- -decodeClientKeyXchg :: CurrentParams -> Get Handshake-decodeClientKeyXchg cp =- -- case ClientKeyXchg <$> (remaining >>= getBytes)+decodeServerKeyXchg :: CurrentParams -> Get Handshake+decodeServerKeyXchg cp = case cParamsKeyXchgType cp of- Nothing -> fail "no client key exchange type"- Just cke -> ClientKeyXchg <$> parseCKE cke- where- parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)- parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic- parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic- parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic- parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic- parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic- parseCKE _ = fail "unsupported client key exchange type"- parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16- parseClientECDHPublic = CKX_ECDH <$> getOpaque8--decodeServerKeyXchg_DH :: Get ServerDHParams-decodeServerKeyXchg_DH = getServerDHParams---- We don't support ECDH_Anon at this moment--- decodeServerKeyXchg_ECDH :: Get ServerECDHParams--decodeServerKeyXchg_RSA :: Get ServerRSAParams-decodeServerKeyXchg_RSA =- ServerRSAParams- <$> getInteger16 -- modulus- <*> getInteger16 -- exponent+ Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke+ Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) decodeServerKeyXchgAlgorithmData :: Version@@ -298,12 +260,60 @@ bs <- remaining >>= getBytes return $ SKX_Unknown bs -decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp =+decodeServerKeyXchg_DH :: Get ServerDHParams+decodeServerKeyXchg_DH = getServerDHParams++-- We don't support ECDH_Anon at this moment+-- decodeServerKeyXchg_ECDH :: Get ServerECDHParams++decodeServerKeyXchg_RSA :: Get ServerRSAParams+decodeServerKeyXchg_RSA =+ ServerRSAParams+ <$> getInteger16 -- modulus+ <*> getInteger16 -- exponent++----++decodeCertRequest :: CurrentParams -> Get Handshake+decodeCertRequest _cp = do+ certTypes <- map CertificateType <$> getWords8+ sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms+ CertRequest certTypes sigHashAlgs <$> getDNames+ where+ getSignatureHashAlgorithms len =+ getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++----++decodeServerHelloDone :: Get Handshake+decodeServerHelloDone = return ServerHelloDone++decodeCertVerify :: CurrentParams -> Get Handshake+decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)++decodeClientKeyXchg :: CurrentParams -> Get Handshake+decodeClientKeyXchg cp =+ -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of- Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke- Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes)+ Nothing -> fail "no client key exchange type"+ Just cke -> ClientKeyXchg <$> parseCKE cke+ where+ parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)+ parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic+ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic+ parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic+ parseCKE _ = fail "unsupported client key exchange type"+ parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16+ parseClientECDHPublic = CKX_ECDH <$> getOpaque8 +decodeFinished :: Get Handshake+decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes)++----------------------------------------------------------------+-- encode HANDSHAKE+ encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = encodeHandshake' o@@ -315,6 +325,7 @@ encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len encodeHandshake' :: Handshake -> ByteString+encodeHandshake' HelloRequest = "" encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do putBinaryVersion version putClientRandom32 random@@ -331,12 +342,10 @@ putWord8 compressionID putExtensions exts return ()+encodeHandshake' (NewSessionTicket life ticket) = runPut $ do+ putWord32 life+ putOpaque16 ticket encodeHandshake' (Certificate (TLSCertificateChain cc)) = encodeCertificate cc-encodeHandshake' (ClientKeyXchg ckx) = runPut $ do- case ckx of- CKX_RSA encryptedPreMain -> putBytes encryptedPreMain- CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic- CKX_ECDH bytes -> putOpaque8 bytes encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented"@@ -347,8 +356,6 @@ SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshake': cannot handle: " ++ show skg)-encodeHandshake' HelloRequest = ""-encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do putWords8 (map fromCertificateType certTypes) putWords16 $@@ -357,14 +364,33 @@ ) sigAlgs putDNames certAuthorities+encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned+encodeHandshake' (ClientKeyXchg ckx) = runPut $ do+ case ckx of+ CKX_RSA encryptedPreMain -> putBytes encryptedPreMain+ CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic+ CKX_ECDH bytes -> putOpaque8 bytes encodeHandshake' (Finished (VerifyData opaque)) = runPut $ putBytes opaque-encodeHandshake' (NewSessionTicket life ticket) = runPut $ do- putWord32 life- putOpaque16 ticket ------------------------------------------------------------+-- CA distinguished names +-- | Decode a list CA distinguished names+getDNames :: Get [DistinguishedName]+getDNames = do+ dNameLen <- getWord16+ -- FIXME: Decide whether to remove this check completely or to make it an option.+ -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"+ getList (fromIntegral dNameLen) getDName+ where+ getDName = do+ dName <- getOpaque16+ when (B.length dName == 0) $ fail "certrequest: invalid DN length"+ dn <-+ either fail return $ decodeASN1Object "cert request DistinguishedName" dName+ return (2 + B.length dName, dn)+ -- | Encode a list of distinguished names. putDNames :: [DistinguishedName] -> Put putDNames dnames = do@@ -376,6 +402,8 @@ -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1Object dn +------------------------------------------------------------+ {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32@@ -395,6 +423,8 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r +------------------------------------------------------------+ getSession :: Get Session getSession = do len8 <- getWord8@@ -408,6 +438,8 @@ putSession (Session Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s +------------------------------------------------------------+ getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do@@ -424,6 +456,8 @@ putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) +------------------------------------------------------------+ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- HashAlgorithm <$> getWord8@@ -434,12 +468,16 @@ putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) = putWord8 h >> putWord8 s +------------------------------------------------------------+ getServerDHParams :: Get ServerDHParams getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] +------------------------------------------------------------+ -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do@@ -461,6 +499,8 @@ putWord16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint +------------------------------------------------------------+ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned@@ -471,19 +511,7 @@ putDigitallySigned (DigitallySigned h sig) = putSignatureHashAlgorithm h >> putOpaque16 sig -{-- - decode and encode ALERT- -}--decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec = runGetErr "changecipherspec" $ do- x <- getWord8- when (x /= 1) $ fail "unknown change cipher spec content"- len <- remaining- when (len /= 0) $ fail "the length of CSS must be 1"--encodeChangeCipherSpec :: ByteString-encodeChangeCipherSpec = runPut (putWord8 1)+------------------------------------------------------------ -- RSA pre-main secret decodePreMainSecret :: ByteString -> Either TLSError (Version, ByteString)@@ -494,23 +522,9 @@ encodePreMainSecret :: Version -> ByteString -> ByteString encodePreMainSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) --- | in certain cases, we haven't manage to decode ServerKeyExchange properly,--- because the decoding was too eager and the cipher wasn't been set yet.--- we keep the Server Key Exchange in it unparsed format, and this function is--- able to really decode the server key xchange if it's unparsed.-decodeReallyServerKeyXchgAlgorithmData- :: Version- -> CipherKeyExchangeType- -> ByteString- -> Either TLSError ServerKeyXchgAlgorithmData-decodeReallyServerKeyXchgAlgorithmData ver cke =- runGetErr- "server-key-xchg-algorithm-data"- (decodeServerKeyXchgAlgorithmData ver cke)+------------------------------------------------------------+-- generate things for packet content -{-- - generate things for packet content- -} type PRF = ByteString -> ByteString -> Int -> ByteString -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384@@ -595,6 +609,8 @@ generateServerFinished ver ciph = generateFinished_TLS (getPRF ver ciph) "server finished" +------------------------------------------------------------+ encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedDHParams dhparams cran sran =@@ -614,3 +630,19 @@ encodeCertificate cc = runPut $ putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc++------------------------------------------------------------++-- | in certain cases, we haven't manage to decode ServerKeyExchange properly,+-- because the decoding was too eager and the cipher wasn't been set yet.+-- we keep the Server Key Exchange in it unparsed format, and this function is+-- able to really decode the server key xchange if it's unparsed.+decodeReallyServerKeyXchgAlgorithmData+ :: Version+ -> CipherKeyExchangeType+ -> ByteString+ -> Either TLSError ServerKeyXchgAlgorithmData+decodeReallyServerKeyXchgAlgorithmData ver cke =+ runGetErr+ "server-key-xchg-algorithm-data"+ (decodeServerKeyXchgAlgorithmData ver cke)
Network/TLS/Packet13.hs view
@@ -9,7 +9,10 @@ encodeCertificate13, ) where +import Codec.Compression.Zlib+import qualified Control.Exception as E import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.X509 ( CertificateChain, CertificateChainRaw (..),@@ -23,7 +26,10 @@ import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire+import System.IO.Unsafe +----------------------------------------------------------------+ encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where@@ -45,30 +51,48 @@ putWord16 $ fromCipherId cipherId putWord8 0 -- compressionID nullCompression putExtensions exts+encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do+ putWord32 life+ putWord32 ageadd+ putOpaque8 nonce+ putOpaque16 label+ putExtensions exts+encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts+encodeHandshake13' (Certificate13 reqctx (TLSCertificateChain cc) ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts-encodeHandshake13' (Certificate13 reqctx (TLSCertificateChain cc) ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do putSignatureHashAlgorithm hs putOpaque16 sig encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat-encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do- putWord32 life- putWord32 ageadd- putOpaque8 nonce- putOpaque16 label- putExtensions exts-encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1+encodeHandshake13' (CompressedCertificate13 reqctx (TLSCertificateChain cc) ess) = runPut $ do+ putWord16 1 -- zlib: fixme+ let bs = encodeCertificate13 reqctx cc ess+ putWord24 $ fromIntegral $ B.length bs+ putOpaque24 $ BL.toStrict $ compress $ BL.fromStrict bs encodeHandshakeHeader13 :: HandshakeType -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (fromHandshakeType ty) putWord24 len +encodeCertificate13+ :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString+encodeCertificate13 reqctx cc ess = runPut $ do+ putOpaque8 reqctx+ putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+ where+ CertificateChainRaw certs = encodeCertificateChain cc+ putCert (certRaw, exts) = do+ putOpaque24 certRaw+ putExtensions exts++----------------------------------------------------------------+ decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of GotError err -> throwError err@@ -86,19 +110,22 @@ content <- getOpaque24 return (ty, content) +{- FOURMOLU_DISABLE -} decodeHandshake13 :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of- HandshakeType_ServerHello -> decodeServerHello13- HandshakeType_Finished -> decodeFinished13- HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13- HandshakeType_CertRequest -> decodeCertRequest13- HandshakeType_Certificate -> decodeCertificate13- HandshakeType_CertVerify -> decodeCertVerify13- HandshakeType_NewSessionTicket -> decodeNewSessionTicket13- HandshakeType_EndOfEarlyData -> return EndOfEarlyData13- HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_ServerHello -> decodeServerHello13+ HandshakeType_NewSessionTicket -> decodeNewSessionTicket13+ HandshakeType_EndOfEarlyData -> return EndOfEarlyData13+ HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13+ HandshakeType_Certificate -> decodeCertificate13+ HandshakeType_CertRequest -> decodeCertRequest13+ HandshakeType_CertVerify -> decodeCertVerify13+ HandshakeType_Finished -> decodeFinished13+ HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_CompressedCertificate -> decodeCompressedCertificate13 (HandshakeType x) -> fail $ "Unsupported HandshakeType " ++ show x+{- FOURMOLU_ENABLE -} decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do@@ -107,11 +134,18 @@ session <- getSession cipherid <- CipherId <$> getWord16 _comp <- getWord8- exts <- fromIntegral <$> getWord16 >>= getExtensions+ exts <- getWord16 >>= getExtensions . fromIntegral return $ ServerHello13 random session cipherid exts -decodeFinished13 :: Get Handshake13-decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes)+decodeNewSessionTicket13 :: Get Handshake13+decodeNewSessionTicket13 = do+ life <- getWord32+ ageadd <- getWord32+ nonce <- getOpaque8+ label <- getOpaque16+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ NewSessionTicket13 life ageadd nonce label exts decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 =@@ -119,13 +153,6 @@ len <- fromIntegral <$> getWord16 getExtensions len -decodeCertRequest13 :: Get Handshake13-decodeCertRequest13 = do- reqctx <- getOpaque8- len <- fromIntegral <$> getWord16- exts <- getExtensions len- return $ CertRequest13 reqctx exts- decodeCertificate13 :: Get Handshake13 decodeCertificate13 = do reqctx <- getOpaque8@@ -142,19 +169,19 @@ exts <- getExtensions len return (3 + l + 2 + len, (cert, exts)) +decodeCertRequest13 :: Get Handshake13+decodeCertRequest13 = do+ reqctx <- getOpaque8+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ CertRequest13 reqctx exts+ decodeCertVerify13 :: Get Handshake13 decodeCertVerify13 = CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) -decodeNewSessionTicket13 :: Get Handshake13-decodeNewSessionTicket13 = do- life <- getWord32- ageadd <- getWord32- nonce <- getOpaque8- label <- getOpaque16- len <- fromIntegral <$> getWord16- exts <- getExtensions len- return $ NewSessionTicket13 life ageadd nonce label exts+decodeFinished13 :: Get Handshake13+decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) decodeKeyUpdate13 :: Get Handshake13 decodeKeyUpdate13 = do@@ -164,13 +191,25 @@ 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x -encodeCertificate13- :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString-encodeCertificate13 reqctx cc ess = runPut $ do- putOpaque8 reqctx- putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+decodeCompressedCertificate13 :: Get Handshake13+decodeCompressedCertificate13 = do+ algo <- getWord16+ when (algo /= 1) $ fail "comp algo is not supported" -- fixme+ len <- getWord24+ bs <- getOpaque24+ if bs == ""+ then fail "empty compressed certificate"+ else case decompressIt bs of+ Left e -> fail (show e)+ Right bs' -> do+ when (B.length bs' /= len) $ fail "plain length is wrong"+ case runGetMaybe decodeCertificate13 bs' of+ Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess+ -- _ -> fail "compressed certificate cannot be parsed"+ _ -> fail $ "invalid compressed certificate: len = " ++ show len++decompressIt :: ByteString -> Either DecompressError ByteString+decompressIt inp = unsafePerformIO $ E.handle handler $ do+ Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp)) where- CertificateChainRaw certs = encodeCertificateChain cc- putCert (certRaw, exts) = do- putOpaque24 certRaw- putExtensions exts+ handler e = return $ Left (e :: DecompressError)
Network/TLS/Parameters.hs view
@@ -16,6 +16,8 @@ defaultSupported, Shared (..), defaultShared,+ Limit (..),+ defaultLimit, -- * Parameters MaxFragmentEnum (..),@@ -44,7 +46,7 @@ import Network.TLS.Types (HostName) import Network.TLS.X509 -type CommonParams = (Supported, Shared, DebugParams)+type CommonParams = (Supported, Shared, DebugParams, Limit) -- | All settings should not be used in production data DebugParams = DebugParams@@ -69,6 +71,7 @@ -- Default: no printing } +-- | Default value for 'DebugParams' defaultDebugParams :: DebugParams defaultDebugParams = DebugParams@@ -83,6 +86,8 @@ instance Default DebugParams where def = defaultDebugParams +{-# DEPRECATED clientUseMaxFragmentLength "UseMaxFragmentLength is deprecated" #-}+ data ClientParams = ClientParams { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- ^@@ -137,9 +142,11 @@ -- is automatically re-sent. -- -- Default: 'False'+ , clientLimit :: Limit } deriving (Show) +-- | Default value for 'ClientParams' defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams@@ -153,6 +160,7 @@ , clientSupported = def , clientDebug = defaultDebugParams , clientUseEarlyData = False+ , clientLimit = defaultLimit } data ServerParams = ServerParams@@ -194,6 +202,7 @@ -- Acceptable value range is 0 to 604800 (7 days). -- -- Default: 7200 (2 hours)+ , serverLimit :: Limit } deriving (Show) @@ -209,6 +218,7 @@ , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 7200+ , serverLimit = defaultLimit } instance Default ServerParams where@@ -638,6 +648,7 @@ -- Default: 'return' } +-- | Default value for 'ServerHooks' defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks@@ -675,3 +686,36 @@ , infoIsEarlyDataAccepted :: Bool } deriving (Show, Eq)++-- | Limitations for security.+--+-- @since 2.1.7+data Limit = Limit+ { limitRecordSize :: Maybe Int+ -- ^ Record size limit defined in RFC 8449.+ --+ -- If 'Nothing', the "record_size_limit" extension is not used.+ --+ -- In the case of 'Just': A client sends the "record_size_limit"+ -- extension with this value to the server. A server sends back+ -- this extension with its own value if a client sends the+ -- extension. When negotiated, both my limit and peer's limit+ -- are enabled for protected communication.+ --+ -- Default: Nothing+ , limitHandshakeFragment :: Int+ -- ^ The limit to accept the number of each handshake message.+ -- For instance, a nasty client may send many fragments of client+ -- certificate.+ --+ -- Default: 32+ }+ deriving (Eq, Show)++-- | Default value for 'Limit'.+defaultLimit :: Limit+defaultLimit =+ Limit+ { limitRecordSize = Nothing+ , limitHandshakeFragment = 32+ }
Network/TLS/QUIC.hs view
@@ -171,10 +171,13 @@ tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks@@ -201,10 +204,13 @@ tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks
− Network/TLS/Receiving.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Receiving (- processPacket,- processPacket13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Handshake.State-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Util-import Network.TLS.Wire--processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet)-processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment-processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of- Left err -> return $ Left err- Right _ -> do- switchRxEncryption ctx- return $ Right ChangeCipherSpec-processPacket ctx (Record ProtocolType_Handshake ver fragment) = do- keyxchg <-- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)- usingState ctx $ do- let currentParams =- CurrentParams- { cParamsVersion = ver- , cParamsKeyXchgType = keyxchg- }- -- get back the optional continuation, and parse as many handshake record as possible.- mCont <- gets stHandshakeRecordCont- modify (\st -> st{stHandshakeRecordCont = Nothing})- hss <- parseMany currentParams mCont (fragmentGetBytes fragment)- return $ Handshake hss- where- parseMany currentParams mCont bs =- case fromMaybe decodeHandshakeRecord mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake currentParams ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake currentParams ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany currentParams Nothing left-processPacket _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")--switchRxEncryption :: Context -> IO ()-switchRxEncryption ctx =- usingHState ctx (gets hstPendingRxState) >>= \rx ->- modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)--------------------------------------------------------------------processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)-processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of- Left err -> return $ Left err- Right _ -> 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 (fragmentGetBytes fragment)- return $ Handshake13 hss- where- parseMany mCont bs =- case fromMaybe decodeHandshakeRecord13 mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake13 ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake13 ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany Nothing left-processPacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
Network/TLS/Record.hs view
@@ -15,12 +15,11 @@ rawToRecord, recordToHeader, Plaintext,- Compressed, Ciphertext, - -- * Engage and disengage from the record layer- engageRecord,- disengageRecord,+ -- * Encrypt and decrypt from the record layer+ encryptRecord,+ decryptRecord, -- * State tracking RecordM,@@ -31,7 +30,7 @@ setRecordIV, ) where -import Network.TLS.Record.Disengage-import Network.TLS.Record.Engage+import Network.TLS.Record.Decrypt+import Network.TLS.Record.Encrypt import Network.TLS.Record.State import Network.TLS.Record.Types
+ Network/TLS/Record/Decrypt.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.Record.Decrypt (+ decryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))+import qualified Data.ByteArray as B (convert, xor)+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Crypto+import Network.TLS.ErrT+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Struct+import Network.TLS.Util+import Network.TLS.Wire++decryptRecord :: Record Ciphertext -> Int -> RecordM (Record Plaintext)+decryptRecord record@(Record ct ver fragment) lim = do+ st <- get+ case stCipher st of+ 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 lim+ where+ noDecryption = onRecordFragment record $ fragmentUncipher $ checkPlainLimit lim+ decryptData13 mver e st = case ct of+ ProtocolType_AppData -> do+ inner <- decryptData mver record e st (lim + 1)+ case unInnerPlaintext inner of+ Left message -> throwError $ Error_Protocol message UnexpectedMessage+ Right (ct', d) -> return $ Record ct' ver $ fragmentPlaintext d+ ProtocolType_ChangeCipherSpec -> noDecryption+ ProtocolType_Alert -> noDecryption+ _ ->+ throwError $ Error_Protocol "illegal plain text" UnexpectedMessage++unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)+unInnerPlaintext inner =+ case B.unsnoc dc of+ Nothing -> Left $ unknownContentType13 (0 :: Word8)+ Just (bytes, c)+ | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->+ Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")+ | otherwise -> Right (ProtocolType c, 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.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest new_hdr $ cipherDataContent cdata+ return (expected_digest == digest)++ -- check if the padding is filled with the correct pattern if it exists+ -- (before TLS10 this checks instead that the padding length is minimal)+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just (pad, _blksz) -> do+ let b = B.length pad - 1+ return $ B.replicate (B.length pad) (fromIntegral b) == pad++ unless (macValid &&! paddingValid) $+ throwError $+ Error_Protocol "bad record mac Stream/Block" BadRecordMac++ return $ cipherDataContent cdata++checkPlainLimit :: Int -> ByteString -> RecordM ByteString+checkPlainLimit lim plain+ | len > lim =+ throwError $+ Error_Protocol+ ( "plaintext exceeding record size limit: "+ ++ show len+ ++ " > "+ ++ show lim+ )+ RecordOverflow+ | otherwise = return plain+ where+ len = B.length plain++decryptData+ :: Version+ -> Record Ciphertext+ -> ByteString+ -> RecordState+ -> Int+ -> RecordM ByteString+decryptData ver record econtent tst lim =+ decryptOf (cstKey cst) >>= checkPlainLimit lim+ where+ cipher = fromJust $ stCipher tst+ bulk = cipherBulk cipher+ cst = stCryptState tst+ macSize = hashDigestSize $ cipherHash cipher+ blockSize = bulkBlockSize bulk+ econtentLen = B.length econtent++ sanityCheckError =+ throwError+ (Error_Packet "encrypted content too small for encryption parameters")++ decryptOf :: BulkState -> RecordM ByteString+ decryptOf (BulkStateBlock decryptF) = do+ let minContent = bulkIVSize bulk + max (macSize + 1) blockSize++ -- check if we have enough bytes to cover the minimum for this cipher+ when+ ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)+ sanityCheckError++ {- update IV -}+ (iv, econtent') <-+ get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)+ let (content', iv') = decryptF iv econtent'+ modify $ \txs -> txs{stCryptState = cst{cstIV = iv'}}++ let paddinglength = fromIntegral (B.last content') + 1+ let contentlen = B.length content' - paddinglength - macSize+ (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)+ getCipherData+ record+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just (padding, blockSize)+ }+ decryptOf (BulkStateStream (BulkStream decryptF)) = do+ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < macSize) sanityCheckError++ let (content', bulkStream') = decryptF econtent+ {- update Ctx -}+ let contentlen = B.length content' - macSize+ (content, mac) <- get2i content' (contentlen, macSize)+ modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}+ getCipherData+ record+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ decryptOf (BulkStateAEAD decryptF) = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cipherLen = econtentLen - authTagLen - nonceExpLen++ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError++ (enonce, econtent', authTag) <-+ get3o econtent (nonceExpLen, cipherLen, authTagLen)+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tst+ iv = cstIV (stCryptState tst)+ ivlen = B.length iv+ Header typ v _ = recordToHeader record+ 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+ (content, authTag2) = decryptF nonce econtent' ad++ when (AuthTag (B.convert authTag) /= authTag2) $+ throwError $+ Error_Protocol "bad record mac on AEAD" BadRecordMac++ modify incrRecordState+ return content+ decryptOf BulkStateUninitialized =+ throwError $ Error_Protocol "decrypt state uninitialized" InternalError++ -- handling of outer format can report errors with Error_Packet+ get3o s ls =+ maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls+ get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)++ -- all format errors related to decrypted content are reported+ -- externally as integrity failures, i.e. BadRecordMac+ get3i s ls =+ maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $+ partition3 s ls+ get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)
− Network/TLS/Record/Disengage.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Record.Disengage (- disengageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B--import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Crypto-import Network.TLS.ErrT-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Struct-import Network.TLS.Util-import Network.TLS.Wire--disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext)-disengageRecord = decryptRecord >=> uncompressRecord--uncompressRecord :: Record Compressed -> RecordM (Record Plaintext)-uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes--decryptRecord :: Record Ciphertext -> RecordM (Record Compressed)-decryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- 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 = case ct of- ProtocolType_AppData -> do- inner <- decryptData mver record e st- let len = B.length inner- when (len > 16385) $- throwError $- Error_Protocol- ( "TLS 1.3 inner plaintext exceeding maximum size: "- ++ show len- ++ " > 16385 (2^14 + 1)"- )- RecordOverflow- case unInnerPlaintext inner of- Left message -> throwError $ Error_Protocol message UnexpectedMessage- Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)- ProtocolType_ChangeCipherSpec -> noDecryption- ProtocolType_Alert -> noDecryption- _ ->- throwError $ Error_Protocol "illegal plain text" UnexpectedMessage--unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)-unInnerPlaintext inner =- case B.unsnoc dc of- Nothing -> Left $ unknownContentType13 (0 :: Word8)- Just (bytes, c)- | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->- Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")- | otherwise -> Right (ProtocolType c, 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.- macValid <- case cipherDataMAC cdata of- Nothing -> return True- Just digest -> do- let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)- expected_digest <- makeDigest new_hdr $ cipherDataContent cdata- return (expected_digest == digest)-- -- check if the padding is filled with the correct pattern if it exists- -- (before TLS10 this checks instead that the padding length is minimal)- paddingValid <- case cipherDataPadding cdata of- Nothing -> return True- Just (pad, _blksz) -> do- let b = B.length pad - 1- return $ B.replicate (B.length pad) (fromIntegral b) == pad-- unless (macValid &&! paddingValid) $- throwError $- Error_Protocol "bad record mac Stream/Block" BadRecordMac-- return $ cipherDataContent cdata--decryptData- :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString-decryptData ver record econtent tst = decryptOf (cstKey cst)- where- cipher = fromJust $ stCipher tst- bulk = cipherBulk cipher- cst = stCryptState tst- macSize = hashDigestSize $ cipherHash cipher- blockSize = bulkBlockSize bulk- econtentLen = B.length econtent-- sanityCheckError =- throwError- (Error_Packet "encrypted content too small for encryption parameters")-- decryptOf :: BulkState -> RecordM ByteString- decryptOf (BulkStateBlock decryptF) = do- let minContent = bulkIVSize bulk + max (macSize + 1) blockSize-- -- check if we have enough bytes to cover the minimum for this cipher- when- ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)- sanityCheckError-- {- update IV -}- (iv, econtent') <-- get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)- let (content', iv') = decryptF iv econtent'- modify $ \txs -> txs{stCryptState = cst{cstIV = iv'}}-- let paddinglength = fromIntegral (B.last content') + 1- let contentlen = B.length content' - paddinglength - macSize- (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)- getCipherData- record- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just (padding, blockSize)- }- decryptOf (BulkStateStream (BulkStream decryptF)) = do- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < macSize) sanityCheckError-- let (content', bulkStream') = decryptF econtent- {- update Ctx -}- let contentlen = B.length content' - macSize- (content, mac) <- get2i content' (contentlen, macSize)- modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}- getCipherData- record- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- decryptOf (BulkStateAEAD decryptF) = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cipherLen = econtentLen - authTagLen - nonceExpLen-- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError-- (enonce, econtent', authTag) <-- get3o econtent (nonceExpLen, cipherLen, authTagLen)- let encodedSeq = encodeWord64 $ msSequence $ stMacState tst- iv = cstIV (stCryptState tst)- ivlen = B.length iv- Header typ v _ = recordToHeader record- 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- (content, authTag2) = decryptF nonce econtent' ad-- when (AuthTag (B.convert authTag) /= authTag2) $- throwError $- Error_Protocol "bad record mac on AEAD" BadRecordMac-- modify incrRecordState- return content- decryptOf BulkStateUninitialized =- throwError $ Error_Protocol "decrypt state uninitialized" InternalError-- -- handling of outer format can report errors with Error_Packet- get3o s ls =- maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls- get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)-- -- all format errors related to decrypted content are reported- -- externally as integrity failures, i.e. BadRecordMac- get3i s ls =- maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $- partition3 s ls- get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)
+ Network/TLS/Record/Encrypt.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- 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.+module Network.TLS.Record.Encrypt (+ encryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))++import qualified Data.ByteArray as B (convert, xor)+import qualified Data.ByteString as B+import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Wire++-- when Tx Encrypted is set, we pass the data through encryptContent, otherwise+-- we just return the compress payload directly as the ciphered one+--+encryptRecord :: Record Plaintext -> RecordM (Record Ciphertext)+encryptRecord record@(Record ct ver fragment) = do+ st <- get+ case stCipher st of+ 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' = fragmentPlaintext $ innerPlaintext ct bytes+ record' = Record ProtocolType_AppData ver fragment'+ onRecordFragment record' $ fragmentCipher (encryptContent True record')++innerPlaintext :: ProtocolType -> ByteString -> ByteString+innerPlaintext (ProtocolType c) bytes = runPut $ do+ putBytes bytes+ putWord8 c -- non zero!+ -- fixme: zeros padding++encryptContent :: Bool -> Record Plaintext -> ByteString -> RecordM ByteString+encryptContent tls13 record content = do+ cst <- getCryptState+ bulk <- getBulk+ case cstKey cst of+ BulkStateBlock encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptBlock encryptF content' bulk+ BulkStateStream encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptStream encryptF content'+ BulkStateAEAD encryptF ->+ encryptAead tls13 bulk encryptF content record+ BulkStateUninitialized ->+ return content++encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString+encryptBlock encryptF content bulk = do+ cst <- getCryptState+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding =+ if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize)+ in let padbyte' = if padbyte == 0 then blockSize else padbyte+ in B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else B.empty++ let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]++ return $ B.concat [cstIV cst, e]++encryptStream :: BulkStream -> ByteString -> RecordM ByteString+encryptStream (BulkStream encryptF) content = do+ cst <- getCryptState+ let (!e, !newBulkStream) = encryptF content+ modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}+ return e++encryptAead+ :: Bool+ -> Bulk+ -> BulkAEAD+ -> ByteString+ -> Record Plaintext+ -> RecordM ByteString+encryptAead tls13 bulk encryptF content record = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cst <- getCryptState+ encodedSeq <- encodeWord64 <$> getMacSequence++ 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]+ (e, AuthTag authtag) = encryptF nonce content ad+ econtent+ | nonceExpLen == 0 = e `B.append` B.convert authtag+ | otherwise = B.concat [encodedSeq, e, B.convert authtag]+ modify incrRecordState+ return econtent++getCryptState :: RecordM CryptState+getCryptState = stCryptState <$> get
− Network/TLS/Record/Engage.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- |--- 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.-module Network.TLS.Record.Engage (- engageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))--import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Wire--engageRecord :: Record Plaintext -> RecordM (Record Ciphertext)-engageRecord = compressRecord >=> encryptRecord--compressRecord :: Record Plaintext -> RecordM (Record Compressed)-compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes---- when Tx Encrypted is set, we pass the data through encryptContent, otherwise--- we just return the compress payload directly as the ciphered one----encryptRecord :: Record Compressed -> RecordM (Record Ciphertext)-encryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- 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')--innerPlaintext :: ProtocolType -> ByteString -> ByteString-innerPlaintext (ProtocolType c) bytes = runPut $ do- putBytes bytes- putWord8 c -- 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- BulkStateBlock encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptBlock encryptF content' bulk- BulkStateStream encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptStream encryptF content'- BulkStateAEAD encryptF ->- encryptAead tls13 bulk encryptF content record- BulkStateUninitialized ->- return content--encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString-encryptBlock encryptF content bulk = do- cst <- getCryptState- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding =- if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize)- in let padbyte' = if padbyte == 0 then blockSize else padbyte- in B.replicate padbyte' (fromIntegral (padbyte' - 1))- else B.empty-- let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]-- return $ B.concat [cstIV cst, e]--encryptStream :: BulkStream -> ByteString -> RecordM ByteString-encryptStream (BulkStream encryptF) content = do- cst <- getCryptState- let (!e, !newBulkStream) = encryptF content- modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}- return e--encryptAead- :: Bool- -> Bulk- -> BulkAEAD- -> ByteString- -> Record Compressed- -> RecordM ByteString-encryptAead tls13 bulk encryptF content record = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cst <- getCryptState- encodedSeq <- encodeWord64 <$> getMacSequence-- 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]- (e, AuthTag authtag) = encryptF nonce content ad- econtent- | nonceExpLen == 0 = e `B.append` B.convert authtag- | otherwise = B.concat [encodedSeq, e, B.convert authtag]- modify incrRecordState- return econtent--getCryptState :: RecordM CryptState-getCryptState = stCryptState <$> get
Network/TLS/Record/Layer.hs view
@@ -18,10 +18,10 @@ -> RecordLayer [(ann, ByteString)] newTransparentRecordLayer get send recv = RecordLayer- { recordEncode = transparentEncodeRecord get+ { recordEncode12 = transparentEncodeRecord get , recordEncode13 = transparentEncodeRecord get , recordSendBytes = transparentSendBytes send- , recordRecv = \ctx _ -> transparentRecvRecord recv ctx+ , recordRecv12 = transparentRecvRecord recv , recordRecv13 = transparentRecvRecord recv }
− Network/TLS/Record/Reading.hs
@@ -1,103 +0,0 @@--- | TLS record layer in Rx direction-module Network.TLS.Record.Reading (- recvRecord,- recvRecord13,-) where--import qualified Data.ByteString as B--import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--------------------------------------------------------------------exceeds :: Integral ty => Context -> Int -> ty -> Bool-exceeds ctx overhead actual =- case ctxFragmentSize ctx of- Nothing -> False- Just sz -> fromIntegral actual > sz + overhead--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- runRxRecordState ctx $ do- r <- decodeRecordM header content- let Record _ _ fragment = r- when (exceeds ctx overhead $ B.length (fragmentGetBytes fragment)) $- throwError contentSizeExceeded- return r- where- overhead = if pt == ProtocolType_AppData then appDataOverhead else 0--decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext)-decodeRecordM header content = disengageRecord erecord- where- erecord = rawToRecord header (fragmentCiphertext content)--contentSizeExceeded :: TLSError-contentSizeExceeded = Error_Protocol "record content exceeding maximum size" RecordOverflow---------------------------------------------------------------------- | recvRecord receive a full TLS record (header + data), from the other side.------ The record is disengaged from the record layer-recvRecord- :: Context- -- ^ TLS context- -> Int- -- ^ number of AppData bytes to accept above normal maximum size- -> IO (Either TLSError (Record Plaintext))-recvRecord ctx appDataOverhead =- readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength-- recvLength header@(Header _ _ readlen)- | exceeds ctx 2048 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx appDataOverhead header)--recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))-recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength- recvLength header@(Header _ _ readlen)- | exceeds ctx 256 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx 0 header)--maximumSizeExceeded :: TLSError-maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow--------------------------------------------------------------------readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)-readExactBytes ctx sz = do- hdrbs <- contextRecv ctx sz- if B.length hdrbs == sz- then return $ Right hdrbs- else do- setEOF ctx- return . Left $- if B.null hdrbs- then Error_EOF- else- Error_Packet- ( "partial packet: expecting "- ++ show sz- ++ " bytes, got: "- ++ show (B.length hdrbs)- )
+ Network/TLS/Record/Recv.hs view
@@ -0,0 +1,112 @@+-- | TLS record layer in Rx direction+module Network.TLS.Record.Recv (+ recvRecord12,+ recvRecord13,+) where++import qualified Data.ByteString as B++import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct+import Network.TLS.Types++----------------------------------------------------------------++getMyPlainLimit :: Context -> IO Int+getMyPlainLimit ctx = do+ msiz <- getMyRecordLimit ctx+ return $ case msiz of+ Nothing -> defaultRecordSizeLimit+ Just siz -> siz++getRecord+ :: Context+ -> Header+ -> ByteString+ -> IO (Either TLSError (Record Plaintext))+getRecord ctx header content = do+ withLog ctx $ \logging -> loggingIORecv logging header content+ lim <- getMyPlainLimit ctx+ runRxRecordState ctx $ do+ let erecord = rawToRecord header $ fragmentCiphertext content+ decryptRecord erecord lim++----------------------------------------------------------------++exceedsTLSCiphertext :: Int -> Word16 -> Bool+exceedsTLSCiphertext overhead actual =+ -- In TLS 1.3, overhead is included one more byte for content type.+ fromIntegral actual > defaultRecordSizeLimit + overhead++-- | recvRecord receive a full TLS record (header + data), from the other side.+--+-- The record is disengaged from the record layer+recvRecord12+ :: Context+ -- ^ TLS context+ -> IO (Either TLSError (Record Plaintext))+recvRecord12 ctx =+ readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ where+ recvLengthE = either (return . Left) recvLength++ recvLength header@(Header _ _ readlen) = do+ -- RFC 5246 Section 7.2.2+ -- A TLSCiphertext record was received that had a length more+ -- than 2^14+2048 bytes, or a record decrypted to a+ -- TLSCompressed record with more than 2^14+1024 bytes. This+ -- message is always fatal and should never be observed in+ -- communication between proper implementations (except when+ -- messages were corrupted in the network).+ if exceedsTLSCiphertext 2048 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))+recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ where+ recvLengthE = either (return . Left) recvLength+ recvLength header@(Header _ _ readlen) = do+ -- RFC 8446 Section 5.2:+ -- An AEAD algorithm used in TLS 1.3 MUST NOT produce an+ -- expansion greater than 255 octets. An endpoint that+ -- receives a record from its peer with TLSCiphertext.length+ -- larger than 2^14 + 256 octets MUST terminate the connection+ -- with a "record_overflow" alert. This limit is derived from+ -- the maximum TLSInnerPlaintext length of 2^14 octets + 1+ -- octet for ContentType + the maximum AEAD expansion of 255+ -- octets.+ if exceedsTLSCiphertext 256 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++maximumSizeExceeded :: TLSError+maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow++----------------------------------------------------------------++readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)+readExactBytes ctx sz = do+ hdrbs <- contextRecv ctx sz+ if B.length hdrbs == sz+ then return $ Right hdrbs+ else do+ setEOF ctx+ return . Left $+ if B.null hdrbs+ then Error_EOF+ else+ Error_Packet+ ( "partial packet: expecting "+ ++ show sz+ ++ " bytes, got: "+ ++ show (B.length hdrbs)+ )
+ Network/TLS/Record/Send.hs view
@@ -0,0 +1,61 @@+-- | TLS record layer in Tx direction+module Network.TLS.Record.Send (+ encodeRecord12,+ encodeRecord13,+ sendBytes,+) where++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B++encodeRecordM :: Record Plaintext -> RecordM ByteString+encodeRecordM record = do+ erecord <- encryptRecord record+ let (hdr, content) = recordToRaw erecord+ return $ B.concat [encodeHeader hdr, content]++----------------------------------------------------------------++encodeRecord12 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord12 ctx = prepareRecord12 ctx . encodeRecordM++-- 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+prepareRecord12 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord12 ctx f = do+ txState <- readMVar $ ctxTxRecordState ctx+ let sz = case stCipher txState of+ Nothing -> 0+ Just cipher ->+ if hasRecordIV $ bulkF $ cipherBulk cipher+ then bulkIVSize $ cipherBulk cipher+ else 0 -- to not generate IV+ if sz > 0+ then do+ newIV <- getStateRNG ctx sz+ runTxRecordState ctx (modify (setRecordIV newIV) >> f)+ else runTxRecordState ctx f++----------------------------------------------------------------++encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM++prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord13 = runTxRecordState++----------------------------------------------------------------++sendBytes :: Context -> ByteString -> IO ()+sendBytes ctx dataToSend = do+ withLog ctx $ \logging -> loggingIOSent logging dataToSend+ contextSend ctx dataToSend
Network/TLS/Record/Types.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE EmptyDataDecls #-} -- | The Record Protocol takes messages to be transmitted, fragments--- the data into manageable blocks, optionally compresses the data,--- applies a MAC, encrypts, and transmits the result. Received data--- is decrypted, verified, decompressed, reassembled, and then--- delivered to higher-level clients.+-- the data into manageable blocks. applies a MAC, encrypts, and+-- transmits the result. Received data is decrypted, verified,+-- reassembled, and then delivered to higher-level clients. module Network.TLS.Record.Types ( Header (..), ProtocolType (..),@@ -17,18 +16,14 @@ Fragment, fragmentGetBytes, fragmentPlaintext,- fragmentCompressed, fragmentCiphertext, Plaintext,- Compressed, Ciphertext, -- * manipulate record onRecordFragment,- fragmentCompress, fragmentCipher, fragmentUncipher,- fragmentUncompress, -- * serialize record rawToRecord,@@ -48,15 +43,11 @@ deriving (Show, Eq) data Plaintext-data Compressed data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes -fragmentCompressed :: ByteString -> Fragment Compressed-fragmentCompressed bytes = Fragment bytes- fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes @@ -68,33 +59,19 @@ :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b --- | turn a plaintext record into a compressed record using the compression function supplied-fragmentCompress- :: (ByteString -> RecordM ByteString)- -> Fragment Plaintext- -> RecordM (Fragment Compressed)-fragmentCompress f = fragmentMap f- -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString)- -> Fragment Compressed+ -> Fragment Plaintext -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f --- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+-- | turn a ciphertext fragment into a plaintext fragment using the cipher function supplied fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext- -> RecordM (Fragment Compressed)-fragmentUncipher f = fragmentMap f---- | turn a compressed fragment into a plaintext fragment using the decompression function supplied-fragmentUncompress- :: (ByteString -> RecordM ByteString)- -> Fragment Compressed -> RecordM (Fragment Plaintext)-fragmentUncompress f = fragmentMap f+fragmentUncipher f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString)
− Network/TLS/Record/Writing.hs
@@ -1,59 +0,0 @@--- | TLS record layer in Tx direction-module Network.TLS.Record.Writing (- encodeRecord,- encodeRecord13,- sendBytes,-) where--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B--encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord ctx = prepareRecord ctx . encodeRecordM---- 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-prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord ctx f = do- txState <- readMVar $ ctxTxRecordState ctx- let sz = case stCipher txState of- Nothing -> 0- Just cipher ->- if hasRecordIV $ bulkF $ cipherBulk cipher- then bulkIVSize $ cipherBulk cipher- else 0 -- to not generate IV- if sz > 0- then do- newIV <- getStateRNG ctx sz- runTxRecordState ctx (modify (setRecordIV newIV) >> f)- else runTxRecordState ctx f--encodeRecordM :: Record Plaintext -> RecordM ByteString-encodeRecordM record = do- erecord <- engageRecord record- let (hdr, content) = recordToRaw erecord- return $ B.concat [encodeHeader hdr, content]--------------------------------------------------------------------encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM--prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord13 = runTxRecordState--------------------------------------------------------------------sendBytes :: Context -> ByteString -> IO ()-sendBytes ctx dataToSend = do- withLog ctx $ \logging -> loggingIOSent logging dataToSend- contextSend ctx dataToSend
− Network/TLS/Sending.hs
@@ -1,124 +0,0 @@-module Network.TLS.Sending (- encodePacket12,- encodePacket13,- updateHandshake12,- updateHandshake13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B-import Data.IORef--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Parameters-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types (Role (..))-import Network.TLS.Util---- | encodePacket transform a packet into marshalled data related to current state--- and updating state on the go-encodePacket12- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet- -> IO (Either TLSError bytes)-encodePacket12 ctx recordLayer pkt = do- (ver, _) <- decideRecordVersion ctx- let pt = packetType pkt- mkRecord bs = Record pt ver (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments12 ctx len pkt- bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer ctx)- when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx- return bs---- 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.-packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments12 ctx len (Handshake hss) =- getChunks len . B.concat <$> mapM (updateHandshake12 ctx) hss-packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]-packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]-packetToFragments12 _ _ (AppData x) = return [x]--switchTxEncryption :: Context -> IO ()-switchTxEncryption ctx = do- tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)- (ver, role) <- usingState_ ctx $ do- v <- getVersion- r <- getRole- return (v, r)- liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)- -- set empty packet counter measure if condition are met- when- ( ver <= TLS10- && role == ClientRole- && isCBC tx- && supportedEmptyPacket (ctxSupported ctx)- )- $ liftIO- $ writeIORef (ctxNeedEmptyPacket ctx) True- where- isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)--updateHandshake12 :: Context -> Handshake -> IO ByteString-updateHandshake12 ctx hs = do- usingHState ctx $ do- when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded- when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded- return encoded- where- encoded = encodeHandshake hs--------------------------------------------------------------------encodePacket13- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet13- -> IO (Either TLSError bytes)-encodePacket13 ctx recordLayer pkt = do- let pt = contentType pkt- mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments13 ctx len pkt- fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)--packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]-packetToFragments13 ctx len (Handshake13 hss) =- getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss-packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]-packetToFragments13 _ _ (AppData13 x) = return [x]-packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]--updateHandshake13 :: Context -> Handshake13 -> IO ByteString-updateHandshake13 ctx hs- | isIgnored hs = return encoded- | otherwise = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded- return encoded- where- encoded = encodeHandshake13 hs-- isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand- isHRR _ = False-- isIgnored NewSessionTicket13{} = True- isIgnored KeyUpdate13{} = True- isIgnored _ = False
Network/TLS/Struct.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -101,9 +102,11 @@ HandshakeType_CertVerify, HandshakeType_ClientKeyXchg, HandshakeType_Finished,- HandshakeType_KeyUpdate+ HandshakeType_KeyUpdate,+ HandshakeType_CompressedCertificate ), TLSCertificateChain (..),+ emptyTLSCertificateChain, Handshake (..), CH (..), packetType,@@ -111,9 +114,20 @@ module Network.TLS.HashAndSignature, ExtensionRaw (..), ExtensionID (..),+ showCertificateChain,+ isHelloRetryRequest,+ hrrRandom, ) where -import Data.X509 (CertificateChain, DistinguishedName)+import Data.X509 (+ CertificateChain (..),+ DistinguishedName,+ certSubjectDN,+ getCharacterStringRawData,+ getDistinguishedElements,+ getSigned,+ signedObject,+ ) import Network.TLS.Crypto import Network.TLS.Error@@ -163,11 +177,11 @@ pattern CertificateType_Ed448_Sign = CertificateType 255 -- fixme: dummy value instance Show CertificateType where- show CertificateType_RSA_Sign = "CertificateType_RSA_Sign"- show CertificateType_DSA_Sign = "CertificateType_DSA_Sign"- show CertificateType_ECDSA_Sign = "CertificateType_ECDSA_Sign"- show CertificateType_Ed25519_Sign = "CertificateType_Ed25519_Sign"- show CertificateType_Ed448_Sign = "CertificateType_Ed448_Sign"+ show CertificateType_RSA_Sign = "rsa_sign"+ show CertificateType_DSA_Sign = "dss_sign"+ show CertificateType_ECDSA_Sign = "ecdsa_sign"+ show CertificateType_Ed25519_Sign = "ed25519_sign"+ show CertificateType_Ed448_Sign = "ed448_sign" show (CertificateType x) = "CertificateType " ++ show x {- FOURMOLU_ENABLE -} @@ -186,7 +200,7 @@ deriving (Eq) instance Show DigitallySigned where- show (DigitallySigned hs sig) = "DigitallySigned " ++ show hs ++ " " ++ showBytesHex sig+ show (DigitallySigned hs _sig) = "DigitallySigned " ++ show hs ++ " \"...\"" ---------------------------------------------------------------- @@ -233,8 +247,18 @@ newtype ServerRandom = ServerRandom {unServerRandom :: ByteString} deriving (Eq) instance Show ServerRandom where- show (ServerRandom bs) = "ServerRandom " ++ showBytesHex bs+ show sr@(ServerRandom bs)+ | isHelloRetryRequest sr = "HelloRetryReqest"+ | otherwise = "ServerRandom " ++ showBytesHex bs +hrrRandom :: ServerRandom+hrrRandom =+ ServerRandom+ "\xCF\x21\xAD\x74\xE5\x9A\x61\x11\xBE\x1D\x8C\x02\x1E\x65\xB8\x91\xC2\xA2\x11\x16\x7A\xBB\x8C\x5E\x07\x9E\x09\xE2\xC8\xA8\x33\x9C"++isHelloRetryRequest :: ServerRandom -> Bool+isHelloRetryRequest = (== hrrRandom)+ newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} deriving (Eq) @@ -259,48 +283,51 @@ deriving (Eq) {- FOURMOLU_DISABLE -}-pattern HandshakeType_HelloRequest :: HandshakeType-pattern HandshakeType_HelloRequest = HandshakeType 0-pattern HandshakeType_ClientHello :: HandshakeType-pattern HandshakeType_ClientHello = HandshakeType 1-pattern HandshakeType_ServerHello :: HandshakeType-pattern HandshakeType_ServerHello = HandshakeType 2-pattern HandshakeType_NewSessionTicket :: HandshakeType-pattern HandshakeType_NewSessionTicket = HandshakeType 4-pattern HandshakeType_EndOfEarlyData :: HandshakeType-pattern HandshakeType_EndOfEarlyData = HandshakeType 5-pattern HandshakeType_EncryptedExtensions :: HandshakeType-pattern HandshakeType_EncryptedExtensions = HandshakeType 8-pattern HandshakeType_Certificate :: HandshakeType-pattern HandshakeType_Certificate = HandshakeType 11-pattern HandshakeType_ServerKeyXchg :: HandshakeType-pattern HandshakeType_ServerKeyXchg = HandshakeType 12-pattern HandshakeType_CertRequest :: HandshakeType-pattern HandshakeType_CertRequest = HandshakeType 13-pattern HandshakeType_ServerHelloDone :: HandshakeType-pattern HandshakeType_ServerHelloDone = HandshakeType 14-pattern HandshakeType_CertVerify :: HandshakeType-pattern HandshakeType_CertVerify = HandshakeType 15-pattern HandshakeType_ClientKeyXchg :: HandshakeType-pattern HandshakeType_ClientKeyXchg = HandshakeType 16-pattern HandshakeType_Finished :: HandshakeType-pattern HandshakeType_Finished = HandshakeType 20-pattern HandshakeType_KeyUpdate :: HandshakeType-pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_HelloRequest :: HandshakeType+pattern HandshakeType_HelloRequest = HandshakeType 0+pattern HandshakeType_ClientHello :: HandshakeType+pattern HandshakeType_ClientHello = HandshakeType 1+pattern HandshakeType_ServerHello :: HandshakeType+pattern HandshakeType_ServerHello = HandshakeType 2+pattern HandshakeType_NewSessionTicket :: HandshakeType+pattern HandshakeType_NewSessionTicket = HandshakeType 4+pattern HandshakeType_EndOfEarlyData :: HandshakeType+pattern HandshakeType_EndOfEarlyData = HandshakeType 5+pattern HandshakeType_EncryptedExtensions :: HandshakeType+pattern HandshakeType_EncryptedExtensions = HandshakeType 8+pattern HandshakeType_Certificate :: HandshakeType+pattern HandshakeType_Certificate = HandshakeType 11+pattern HandshakeType_ServerKeyXchg :: HandshakeType+pattern HandshakeType_ServerKeyXchg = HandshakeType 12+pattern HandshakeType_CertRequest :: HandshakeType+pattern HandshakeType_CertRequest = HandshakeType 13+pattern HandshakeType_ServerHelloDone :: HandshakeType+pattern HandshakeType_ServerHelloDone = HandshakeType 14+pattern HandshakeType_CertVerify :: HandshakeType+pattern HandshakeType_CertVerify = HandshakeType 15+pattern HandshakeType_ClientKeyXchg :: HandshakeType+pattern HandshakeType_ClientKeyXchg = HandshakeType 16+pattern HandshakeType_Finished :: HandshakeType+pattern HandshakeType_Finished = HandshakeType 20+pattern HandshakeType_KeyUpdate :: HandshakeType+pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_CompressedCertificate :: HandshakeType+pattern HandshakeType_CompressedCertificate = HandshakeType 25 instance Show HandshakeType where- show HandshakeType_HelloRequest = "HandshakeType_HelloRequest"- show HandshakeType_ClientHello = "HandshakeType_ClientHello"- show HandshakeType_ServerHello = "HandshakeType_ServerHello"- show HandshakeType_Certificate = "HandshakeType_Certificate"- show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg"- show HandshakeType_CertRequest = "HandshakeType_CertRequest"- show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone"- show HandshakeType_CertVerify = "HandshakeType_CertVerify"- show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg"- show HandshakeType_Finished = "HandshakeType_Finished"- show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket"- show (HandshakeType x) = "HandshakeType " ++ show x+ show HandshakeType_HelloRequest = "HandshakeType_HelloRequest"+ show HandshakeType_ClientHello = "HandshakeType_ClientHello"+ show HandshakeType_ServerHello = "HandshakeType_ServerHello"+ show HandshakeType_Certificate = "HandshakeType_Certificate"+ show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg"+ show HandshakeType_CertRequest = "HandshakeType_CertRequest"+ show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone"+ show HandshakeType_CertVerify = "HandshakeType_CertVerify"+ show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg"+ show HandshakeType_Finished = "HandshakeType_Finished"+ show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket"+ show HandshakeType_CompressedCertificate = "HandshakeType_CompressedCertificate"+ show (HandshakeType x) = "HandshakeType " ++ show x {- FOURMOLU_ENABLE -} ----------------------------------------------------------------@@ -384,9 +411,9 @@ deriving (Eq) instance Show ClientKeyXchgAlgorithmData where- show (CKX_RSA bs) = "CKX_RSA " ++ showBytesHex bs+ show (CKX_RSA _bs) = "CKX_RSA \"...\"" show (CKX_DH pub) = "CKX_DH " ++ show pub- show (CKX_ECDH bs) = "CKX_ECDH " ++ showBytesHex bs+ show (CKX_ECDH _bs) = "CKX_ECDH \"...\"" ---------------------------------------------------------------- @@ -399,7 +426,21 @@ newtype TLSCertificateChain = TLSCertificateChain CertificateChain deriving (Eq) instance Show TLSCertificateChain where- show _ = "CertificateChain"+ show (TLSCertificateChain cc) = showCertificateChain cc++emptyTLSCertificateChain :: TLSCertificateChain+emptyTLSCertificateChain = TLSCertificateChain (CertificateChain [])++showCertificateChain :: CertificateChain -> String+showCertificateChain (CertificateChain xs) = show $ map getName xs+ where+ getName =+ maybe "" getCharacterStringRawData+ . lookup [2, 5, 4, 3]+ . getDistinguishedElements+ . certSubjectDN+ . signedObject+ . getSigned data Handshake = ClientHello
Network/TLS/Struct13.hs view
@@ -5,6 +5,7 @@ contentType, KeyUpdate (..), CertReqContext,+ isKeyUpdate13, ) where import Network.TLS.Imports@@ -31,11 +32,12 @@ | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw]- | CertRequest13 CertReqContext [ExtensionRaw] | Certificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]]+ | CertRequest13 CertReqContext [ExtensionRaw] | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate+ | CompressedCertificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]] deriving (Show, Eq) -- | Certificate request context for TLS 1.3.@@ -43,15 +45,16 @@ {- FOURMOLU_DISABLE -} typeOfHandshake13 :: Handshake13 -> HandshakeType-typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello-typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData-typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket-typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions-typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest-typeOfHandshake13 Certificate13{} = HandshakeType_Certificate-typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify-typeOfHandshake13 Finished13{} = HandshakeType_Finished-typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello+typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket+typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData+typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions+typeOfHandshake13 Certificate13{} = HandshakeType_Certificate+typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest+typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify+typeOfHandshake13 Finished13{} = HandshakeType_Finished+typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 CompressedCertificate13{} = HandshakeType_CompressedCertificate contentType :: Packet13 -> ProtocolType contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec@@ -59,3 +62,7 @@ contentType Alert13{} = ProtocolType_Alert contentType AppData13{} = ProtocolType_AppData {- FOURMOLU_ENABLE -}++isKeyUpdate13 :: Handshake13 -> Bool+isKeyUpdate13 (KeyUpdate13 _) = True+isKeyUpdate13 _ = False
Network/TLS/Types.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE PatternSynonyms #-}- module Network.TLS.Types ( module Network.TLS.Types.Cipher, module Network.TLS.Types.Secret,@@ -14,6 +10,7 @@ BigNum (..), bigNumToInteger, bigNumFromInteger,+ defaultRecordSizeLimit, ) where import Network.Socket (HostName)@@ -53,3 +50,9 @@ bigNumFromInteger i = BigNum $ i2osp i ----------------------------------------------------------------++-- For plaintext+-- 2^14 for TLS 1.2+-- 2^14 + 1 for TLS 1.3+defaultRecordSizeLimit :: Int+defaultRecordSizeLimit = 16384
Network/TLS/Types/Cipher.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms #-} module Network.TLS.Types.Cipher where
Network/TLS/Types/Version.hs view
@@ -15,7 +15,7 @@ {- FOURMOLU_DISABLE -} pattern SSL2 :: Version-pattern SSL2 = Version 0x0200+pattern SSL2 = Version 0x0002 pattern SSL3 :: Version pattern SSL3 = Version 0x0300 pattern TLS10 :: Version
Network/TLS/X509.hs view
@@ -17,6 +17,7 @@ ServiceID, wrapCertificateChecks, pubkeyType,+ validateClientCertificate, ) where import Data.X509@@ -59,3 +60,23 @@ pubkeyType :: PubKey -> String pubkeyType = show . pubkeyToAlg++-- | A utility function for client authentication which can be used+-- `onClientCertificate`.+--+-- Since: 2.1.7+validateClientCertificate+ :: CertificateStore+ -> ValidationCache+ -> CertificateChain+ -> IO CertificateUsage+validateClientCertificate store cache cc =+ wrapCertificateChecks+ <$> validate+ HashSHA256+ defaultHooks+ defaultChecks{checkFQHN = False}+ store+ cache+ ("", mempty)+ cc
test/Arbitrary.hs view
@@ -7,12 +7,7 @@ import qualified Data.ByteString as B import Data.List import Data.Word-import Data.X509 (- CertificateChain (..),- ExtKeyUsageFlag,- certPubKey,- getCertificate,- )+import Data.X509 (ExtKeyUsageFlag) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Internal@@ -55,12 +50,12 @@ arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where- arbitrary = DigitallySigned <$> (unsafeHead <$> arbitrary) <*> genByteString 32+ arbitrary = DigitallySigned . unsafeHead <$> arbitrary <*> genByteString 32 instance Arbitrary ExtensionRaw where arbitrary = let arbitraryContent = choose (0, 40) >>= genByteString- in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent+ in ExtensionRaw . ExtensionID <$> arbitrary <*> arbitraryContent instance Arbitrary CertificateType where arbitrary =@@ -124,8 +119,8 @@ <*> return (TLSCertificateChain (CertificateChain certs)) <*> replicateM (length certs) arbitrary , CertVerify13- <$> ( DigitallySigned- <$> (unsafeHead <$> arbitrary)+ <$> ( DigitallySigned . unsafeHead+ <$> arbitrary <*> genByteString 32 ) , Finished13 . VerifyData <$> genByteString 12
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.1.6+version: 2.1.7 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -81,6 +81,8 @@ Network.TLS.HashAndSignature Network.TLS.Hooks Network.TLS.IO+ Network.TLS.IO.Decode+ Network.TLS.IO.Encode Network.TLS.Imports Network.TLS.KeySchedule Network.TLS.MAC@@ -89,26 +91,24 @@ Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake+ Network.TLS.RNG Network.TLS.Record- Network.TLS.Record.Disengage- Network.TLS.Record.Engage+ Network.TLS.Record.Decrypt+ Network.TLS.Record.Encrypt Network.TLS.Record.Layer- Network.TLS.Record.Reading- Network.TLS.Record.Writing+ Network.TLS.Record.Recv+ Network.TLS.Record.Send Network.TLS.Record.State Network.TLS.Record.Types- Network.TLS.RNG- Network.TLS.State Network.TLS.Session- Network.TLS.Sending- Network.TLS.Receiving- Network.TLS.Util- Network.TLS.Util.ASN1+ Network.TLS.State Network.TLS.Types Network.TLS.Types.Cipher Network.TLS.Types.Secret Network.TLS.Types.Session Network.TLS.Types.Version+ Network.TLS.Util+ Network.TLS.Util.ASN1 Network.TLS.Util.Serialization Network.TLS.Wire Network.TLS.X509@@ -133,7 +133,8 @@ network >= 3.1, serialise >= 0.2 && < 0.3, transformers >= 0.5 && < 0.7,- unix-time >= 0.4.11 && < 0.5+ unix-time >= 0.4.11 && < 0.5,+ zlib >= 0.7 && < 0.8 test-suite spec type: exitcode-stdio-1.0
util/Server.hs view
@@ -11,31 +11,48 @@ import Imports +-- "<>" creates *chunks* of lazy ByteString, resulting+-- many TLS fragments.+-- To prevent this, strict ByteString is created first and+-- converted into lazy one.+html :: BL8.ByteString+html =+ BL8.fromStrict $+ "HTTP/1.1 200 OK\r\n"+ <> "Context-Type: text/html\r\n"+ <> "Content-Length: "+ <> C8.pack (show (BS.length body))+ <> "\r\n"+ <> "\r\n"+ <> body+ where+ body = "<html><<body>Hello world!</body></html>"+ server :: Context -> Bool -> IO () server ctx showRequest = do- recvRequest ctx showRequest- sendData ctx $- -- "<>" creates *chunks* of lazy ByteString, resulting- -- many TLS fragments.- -- To prevent this, strict ByteString is created first and- -- converted into lazy one.- BL8.fromStrict $- "HTTP/1.1 200 OK\r\n"- <> "Context-Type: text/html\r\n"- <> "Content-Length: "- <> C8.pack (show (BS.length body))- <> "\r\n"- <> "\r\n"- <> body+ bs <- recvData ctx+ case C8.uncons bs of+ Nothing -> return ()+ Just ('A', _) -> do+ sendData ctx $ BL8.fromStrict bs+ echo ctx+ Just _ -> handleHTML ctx showRequest bs++echo :: Context -> IO ()+echo ctx = loop where- body = "<html><<body>Hello world!</body></html>"+ loop = do+ bs <- recvData ctx+ when (bs /= "") $ do+ sendData ctx $ BL8.fromStrict bs+ loop -recvRequest :: Context -> Bool -> IO ()-recvRequest ctx showRequest = do- getLine <- newSource ctx- loop getLine+handleHTML :: Context -> Bool -> ByteString -> IO ()+handleHTML ctx showRequest ini = do+ getLine <- newSource ctx ini+ process getLine where- loop getLine = do+ process getLine = do bs <- getLine when ("GET /keyupdate" `BS.isPrefixOf` bs) $ do r <- updateKey ctx TwoWay@@ -44,11 +61,19 @@ when showRequest $ do BS.putStr bs BS.putStr "\n"- loop getLine+ consume getLine+ sendData ctx html+ consume getLine = do+ bs <- getLine+ when (bs /= "") $ do+ when showRequest $ do+ BS.putStr bs+ BS.putStr "\n"+ consume getLine -newSource :: Context -> IO (IO ByteString)-newSource ctx = do- ref <- newIORef ""+newSource :: Context -> ByteString -> IO (IO ByteString)+newSource ctx ini = do+ ref <- newIORef ini return $ getline ref where getline :: IORef ByteString -> IO ByteString
util/tls-client.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}@@ -37,6 +38,8 @@ , optRetry :: Bool , optVersions :: [Version] , optALPN :: String+ , optCertFile :: Maybe FilePath+ , optKeyFile :: Maybe FilePath } deriving (Show) @@ -54,6 +57,8 @@ , optRetry = False , optVersions = supportedVersions defaultSupported , optALPN = "http/1.1"+ , optCertFile = Nothing+ , optKeyFile = Nothing } usage :: String@@ -116,13 +121,23 @@ ["alpn"] (ReqArg (\a o -> o{optALPN = a}) "<alpn>") "set ALPN"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = Just fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = Just fl}) "<file>")+ "key file" ] showUsageAndExit :: String -> IO a showUsageAndExit msg = do putStrLn msg putStrLn $ usageInfo usage options- putStrLn $ " <groups> = " ++ (intercalate "," (map fst namedGroups))+ putStrLn $ " <groups> = " ++ intercalate "," (map fst namedGroups) exitFailure clientOpts :: [String] -> IO (Options, [String])@@ -143,6 +158,13 @@ when (null optGroups) $ do putStrLn "Error: unsupported groups" exitFailure+ let onCertReq = \_ -> case optCertFile of+ Just certFile -> case optKeyFile of+ Just keyFile -> do+ Right (!cc, !priv) <- credentialLoadX509 certFile keyFile+ return $ Just (cc, priv)+ _ -> return Nothing+ _ -> return Nothing ref <- newIORef [] let debug | optDebugLog = putStrLn@@ -160,7 +182,7 @@ } mstore <- if optValidate then Just <$> getSystemCertificateStore else return Nothing- let cparams = getClientParams opts host port (smIORef ref) mstore+ let cparams = getClientParams opts host port (smIORef ref) mstore onCertReq client | optALPN == "dot" = clientDNS | otherwise = clientHTTP11@@ -291,8 +313,9 @@ -> ServiceName -> SessionManager -> Maybe CertificateStore+ -> OnCertificateRequest -> ClientParams-getClientParams Options{..} serverName port sm mstore =+getClientParams Options{..} serverName port sm mstore onCertReq = (defaultParamsClient serverName (C8.pack port)) { clientSupported = supported , clientUseServerNameIndication = True@@ -320,6 +343,7 @@ hooks = defaultClientHooks { onSuggestALPN = return $ Just [C8.pack optALPN]+ , onCertificateRequest = onCertReq } validateCache | isJust mstore = sharedValidationCache defaultShared
util/tls-server.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-} module Main where @@ -9,6 +8,7 @@ import qualified Data.ByteString.Char8 as C8 import Data.IORef import qualified Data.Map.Strict as M+import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS import Network.TLS.Internal@@ -16,6 +16,7 @@ import System.Environment (getArgs) import System.Exit import System.IO+import System.X509 import Common import Imports@@ -23,8 +24,10 @@ data Options = Options { optDebugLog :: Bool+ , optClientAuth :: Bool , optShow :: Bool , optKeyLogFile :: Maybe FilePath+ , optTrustedAnchor :: Maybe FilePath , optGroups :: [Group] , optCertFile :: FilePath , optKeyFile :: FilePath@@ -35,9 +38,12 @@ defaultOptions = Options { optDebugLog = False+ , optClientAuth = False , optShow = False , optKeyLogFile = Nothing- , optGroups = supportedGroups defaultSupported+ , optTrustedAnchor = Nothing+ , -- excluding FFDHE8192 for retry+ optGroups = FFDHE8192 `delete` supportedGroups defaultSupported , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem" }@@ -45,6 +51,11 @@ options :: [OptDescr (Options -> Options)] options = [ Option+ ['a']+ ["client-auth"]+ (NoArg (\o -> o{optClientAuth = True}))+ "require client authentication"+ , Option ['d'] ["debug"] (NoArg (\o -> o{optDebugLog = True}))@@ -74,6 +85,11 @@ ["key"] (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>") "key file"+ , Option+ ['t']+ ["trusted-anchor"]+ (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>")+ "trusted anchor file" ] usage :: String@@ -104,11 +120,20 @@ exitFailure smgr <- newSessionManager Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+ mstore <-+ if optClientAuth+ then do+ mstore' <- case optTrustedAnchor of+ Nothing -> Just <$> getSystemCertificateStore+ Just file -> readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ else return Nothing let keyLog = getLogger optKeyLogFile creds = Credentials [cred] makeCipherShowPretty runTCPServer (Just host) port $ \sock -> do- let sparams = getServerParams creds optGroups smgr keyLog+ let sparams = getServerParams creds optGroups smgr keyLog mstore ctx <- contextNew sock sparams when optDebugLog $ contextHookSetLogging@@ -129,26 +154,38 @@ -> [Group] -> SessionManager -> (String -> IO ())+ -> Maybe CertificateStore -> ServerParams-getServerParams creds groups sm keyLog =+getServerParams creds groups sm keyLog mstore = defaultParamsServer { serverSupported = supported , serverShared = shared , serverHooks = hooks , serverDebug = debug , serverEarlyDataSize = 2048+ , serverWantClientCert = isJust mstore } where shared = defaultShared { sharedCredentials = creds , sharedSessionManager = sm+ , sharedCAStore = case mstore of+ Just store -> store+ Nothing -> sharedCAStore defaultShared } supported = defaultSupported { supportedGroups = groups }- hooks = defaultServerHooks{onALPNClientSuggest = Just chooseALPN}+ hooks =+ defaultServerHooks+ { onALPNClientSuggest = Just chooseALPN+ , onClientCertificate = case mstore of+ Nothing -> onClientCertificate defaultServerHooks+ Just _ ->+ validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ } debug = defaultDebugParams{debugKeyLogger = keyLog} chooseALPN :: [ByteString] -> IO ByteString