diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -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 (..)) diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -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 } diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -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 diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -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) diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -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 ------------------------------------------------------------ diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -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 diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -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) diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs --- a/Network/TLS/Handshake/Client/TLS12.hs +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -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") diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -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 diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -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 +-} ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -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 diff --git a/Network/TLS/Handshake/Random.hs b/Network/TLS/Handshake/Random.hs --- a/Network/TLS/Handshake/Random.hs +++ b/Network/TLS/Handshake/Random.hs @@ -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) diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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] diff --git a/Network/TLS/Handshake/Server/ClientHello12.hs b/Network/TLS/Handshake/Server/ClientHello12.hs --- a/Network/TLS/Handshake/Server/ClientHello12.hs +++ b/Network/TLS/Handshake/Server/ClientHello12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs --- a/Network/TLS/Handshake/Server/Common.hs +++ b/Network/TLS/Handshake/Server/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs --- a/Network/TLS/Handshake/Server/TLS12.hs +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -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") diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -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 diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -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}) diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs --- a/Network/TLS/HashAndSignature.hs +++ b/Network/TLS/HashAndSignature.hs @@ -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 -} diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -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 diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/IO/Decode.hs @@ -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") diff --git a/Network/TLS/IO/Encode.hs b/Network/TLS/IO/Encode.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/IO/Encode.hs @@ -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 diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -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) diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -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) diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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 + } diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -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 diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs deleted file mode 100644 --- a/Network/TLS/Receiving.hs +++ /dev/null @@ -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") diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -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 diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Decrypt.hs @@ -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) diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs deleted file mode 100644 --- a/Network/TLS/Record/Disengage.hs +++ /dev/null @@ -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) diff --git a/Network/TLS/Record/Encrypt.hs b/Network/TLS/Record/Encrypt.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Encrypt.hs @@ -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 diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs deleted file mode 100644 --- a/Network/TLS/Record/Engage.hs +++ /dev/null @@ -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 diff --git a/Network/TLS/Record/Layer.hs b/Network/TLS/Record/Layer.hs --- a/Network/TLS/Record/Layer.hs +++ b/Network/TLS/Record/Layer.hs @@ -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 } diff --git a/Network/TLS/Record/Reading.hs b/Network/TLS/Record/Reading.hs deleted file mode 100644 --- a/Network/TLS/Record/Reading.hs +++ /dev/null @@ -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) - ) diff --git a/Network/TLS/Record/Recv.hs b/Network/TLS/Record/Recv.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Recv.hs @@ -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) + ) diff --git a/Network/TLS/Record/Send.hs b/Network/TLS/Record/Send.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Record/Send.hs @@ -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 diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -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) diff --git a/Network/TLS/Record/Writing.hs b/Network/TLS/Record/Writing.hs deleted file mode 100644 --- a/Network/TLS/Record/Writing.hs +++ /dev/null @@ -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 diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs deleted file mode 100644 --- a/Network/TLS/Sending.hs +++ /dev/null @@ -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 diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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 diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -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 diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -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 diff --git a/Network/TLS/Types/Cipher.hs b/Network/TLS/Types/Cipher.hs --- a/Network/TLS/Types/Cipher.hs +++ b/Network/TLS/Types/Cipher.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} module Network.TLS.Types.Cipher where diff --git a/Network/TLS/Types/Version.hs b/Network/TLS/Types/Version.hs --- a/Network/TLS/Types/Version.hs +++ b/Network/TLS/Types/Version.hs @@ -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 diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs --- a/Network/TLS/X509.hs +++ b/Network/TLS/X509.hs @@ -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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls -version: 2.1.6 +version: 2.1.7 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -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 diff --git a/util/Server.hs b/util/Server.hs --- a/util/Server.hs +++ b/util/Server.hs @@ -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 = "<Hello world!" + 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 = "<Hello world!" + 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 diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -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}) "") "set ALPN" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = Just fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = Just fl}) "") + "key file" ] showUsageAndExit :: String -> IO a showUsageAndExit msg = do putStrLn msg putStrLn $ usageInfo usage options - putStrLn $ " = " ++ (intercalate "," (map fst namedGroups)) + putStrLn $ " = " ++ 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 diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -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}) "") "key file" + , Option + ['t'] + ["trusted-anchor"] + (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "") + "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