diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Version 2.1.6 + +* Testing with "tlsfuzzer" again. Now don't send an alert agaist to + peer's alert. Double locking (aka self dead-lock) is fixed. Sending + an alert for known-but-cannot-parse extensions. Other corner cases + are also fixed. +* `tls-client -d` and `tls-server -d` pretty-prints `Handshake`. + ## Version 2.1.5 * Removing the dependency on the async package. diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -22,19 +22,14 @@ cipherAllowedForVersion, hasMAC, hasRecordIV, + elemCipher, + intersectCiphers, + findCipher, ) where -import Crypto.Cipher.Types (AuthTag) import Network.TLS.Crypto (Hash (..), hashDigestSize) -import Network.TLS.Types (CipherID, Version (..)) - -import qualified Data.ByteString as B - --- FIXME convert to newtype -type BulkKey = B.ByteString -type BulkIV = B.ByteString -type BulkNonce = B.ByteString -type BulkAdditionalData = B.ByteString +import Network.TLS.Imports +import Network.TLS.Types data BulkState = BulkStateStream BulkStream @@ -48,16 +43,6 @@ show (BulkStateAEAD _) = "BulkStateAEAD" show BulkStateUninitialized = "BulkStateUninitialized" -newtype BulkStream = BulkStream (B.ByteString -> (B.ByteString, BulkStream)) - -type BulkBlock = BulkIV -> B.ByteString -> (B.ByteString, BulkIV) - -type BulkAEAD = - BulkNonce -> B.ByteString -> BulkAdditionalData -> (B.ByteString, AuthTag) - -data BulkDirection = BulkEncrypt | BulkDecrypt - deriving (Show, Eq) - bulkInit :: Bulk -> BulkDirection -> BulkKey -> BulkState bulkInit bulk direction key = case bulkF bulk of @@ -65,63 +50,12 @@ BulkStreamF ini -> BulkStateStream (ini direction key) BulkAeadF ini -> BulkStateAEAD (ini direction key) -data BulkFunctions - = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock) - | BulkStreamF (BulkDirection -> BulkKey -> BulkStream) - | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) - hasMAC, hasRecordIV :: BulkFunctions -> Bool hasMAC (BulkBlockF _) = True hasMAC (BulkStreamF _) = True hasMAC (BulkAeadF _) = False hasRecordIV = hasMAC -data CipherKeyExchangeType - = CipherKeyExchange_RSA - | CipherKeyExchange_DH_Anon - | CipherKeyExchange_DHE_RSA - | CipherKeyExchange_ECDHE_RSA - | CipherKeyExchange_DHE_DSA - | CipherKeyExchange_DH_DSA - | CipherKeyExchange_DH_RSA - | CipherKeyExchange_ECDH_ECDSA - | CipherKeyExchange_ECDH_RSA - | CipherKeyExchange_ECDHE_ECDSA - | CipherKeyExchange_TLS13 -- not expressed in cipher suite - deriving (Show, Eq) - -data Bulk = Bulk - { bulkName :: String - , bulkKeySize :: Int - , bulkIVSize :: Int - , bulkExplicitIV :: Int -- Explicit size for IV for AEAD Cipher, 0 otherwise - , bulkAuthTagLen :: Int -- Authentication tag length in bytes for AEAD Cipher, 0 otherwise - , bulkBlockSize :: Int - , bulkF :: BulkFunctions - } - -instance Show Bulk where - show bulk = bulkName bulk -instance Eq Bulk where - b1 == b2 = - and - [ bulkName b1 == bulkName b2 - , bulkKeySize b1 == bulkKeySize b2 - , bulkIVSize b1 == bulkIVSize b2 - , bulkBlockSize b1 == bulkBlockSize b2 - ] - --- | Cipher algorithm -data Cipher = Cipher - { cipherID :: CipherID - , cipherName :: String - , cipherHash :: Hash - , cipherBulk :: Bulk - , cipherKeyExchange :: CipherKeyExchangeType - , cipherMinVer :: Maybe Version - , cipherPRFHash :: Maybe Hash - } - cipherKeyBlockSize :: Cipher -> Int cipherKeyBlockSize cipher = 2 * (hashDigestSize (cipherHash cipher) + bulkIVSize bulk + bulkKeySize bulk) where @@ -135,8 +69,16 @@ Nothing -> ver < TLS13 Just cVer -> cVer <= ver && (ver < TLS13 || cVer >= TLS13) -instance Show Cipher where - show c = cipherName c +eqCipher :: CipherID -> Cipher -> Bool +eqCipher cid c = cipherID c == cid -instance Eq Cipher where - (==) c1 c2 = cipherID c1 == cipherID c2 +elemCipher :: [CipherId] -> Cipher -> Bool +elemCipher cids c = cid `elem` cids + where + cid = CipherId $ cipherID c + +intersectCiphers :: [CipherId] -> [Cipher] -> [Cipher] +intersectCiphers peerCiphers myCiphers = filter (elemCipher peerCiphers) myCiphers + +findCipher :: CipherID -> [Cipher] -> Maybe Cipher +findCipher cid = find $ eqCipher cid diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -252,7 +252,11 @@ getTLSUnique ctx = do ver <- liftIO $ usingState_ ctx getVersion if ver == TLS12 - then usingState_ ctx getFirstVerifyData + then do + mx <- usingState_ ctx getFirstVerifyData + case mx of + Nothing -> return Nothing + Just (VerifyData verifyData) -> return $ Just verifyData else return Nothing -- | Getting the "tls-exporter" channel binding for TLS 1.3 (RFC9266). diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -27,7 +27,6 @@ ) where import qualified Control.Exception as E -import Control.Monad (unless, void, when) import Control.Monad.State.Strict import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 @@ -47,6 +46,7 @@ import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.IO +import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.Parameters import Network.TLS.PostHandshake @@ -314,12 +314,18 @@ withWriteLock ctx $ do Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret (_, usedCipher, _, _) <- getTxRecordState ctx + -- mMaxSize is always Just, but anyway + let extract (EarlyDataIndication mMaxSize) = + maybe 0 (fromIntegral . safeNonNegative32) mMaxSize let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionSecret nonce - maxSize = case extensionLookup EID_EarlyData exts - >>= extensionDecode MsgTNewSessionTicket of - Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms - _ -> 0 + maxSize = + lookupAndDecode + EID_EarlyData + MsgTNewSessionTicket + exts + 0 + extract life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk @@ -397,10 +403,13 @@ (_, usedCipher, _, _) <- getTxRecordState ctx let choice = makeCipherChoice TLS13 usedCipher psk = derivePSK choice resumptionSecret nonce - maxSize = case extensionLookup EID_EarlyData exts - >>= extensionDecode MsgTNewSessionTicket of - Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms - _ -> 0 + maxSize = + lookupAndDecode + EID_EarlyData + MsgTNewSessionTicket + exts + 0 + (\(EarlyDataIndication mms) -> fromIntegral $ safeNonNegative32 $ fromJust mms) life7d = min life 604800 -- 7 days max tinfo <- createTLS13TicketInfo life7d (Right add) Nothing sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk @@ -483,12 +492,11 @@ -- -- TLS 1.3 changes session data for every resumed session. session <- usingState_ ctx getSession - withWriteLock ctx $ do - case session of - Session Nothing -> return () - Session (Just sid) -> - -- calling even session ticket manager anyway - sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid + case session of + Session Nothing -> return () + Session (Just sid) -> + -- calling even session ticket manager anyway + sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx E.throwIO (Terminated False reason err) diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -77,7 +77,18 @@ availableECGroups = [P256, P384, P521, X25519, X448] supportedNamedGroups :: [Group] -supportedNamedGroups = [X25519, X448, P256, FFDHE3072, FFDHE4096, P384, FFDHE6144, FFDHE8192, P521] +supportedNamedGroups = + [ X25519 + , X448 + , P256 + , FFDHE2048 + , FFDHE3072 + , FFDHE4096 + , P384 + , FFDHE6144 + , FFDHE8192 + , P521 + ] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). diff --git a/Network/TLS/Error.hs b/Network/TLS/Error.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Error.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms #-} + +module Network.TLS.Error where + +import Control.Exception (Exception (..)) +import Data.Typeable +import Network.TLS.Imports + +---------------------------------------------------------------- + +-- | TLSError that might be returned through the TLS stack. +-- +-- Prior to version 1.8.0, this type had an @Exception@ instance. +-- In version 1.8.0, this instance was removed, and functions in +-- this library now only throw 'TLSException'. +data TLSError + = -- | mainly for instance of Error + Error_Misc String + | -- | A fatal error condition was encountered at a low level. The + -- elements of the tuple give (freeform text description, structured + -- error description). + Error_Protocol String AlertDescription + | -- | A non-fatal error condition was encountered at a low level at a low + -- level. The elements of the tuple give (freeform text description, + -- structured error description). + Error_Protocol_Warning String AlertDescription + | Error_Certificate String + | -- | handshake policy failed. + Error_HandshakePolicy String + | Error_EOF + | Error_Packet String + | Error_Packet_unexpected String String + | Error_Packet_Parsing String + | Error_TCP_Terminate + deriving (Eq, Show, Typeable) + +---------------------------------------------------------------- + +-- | TLS Exceptions. Some of the data constructors indicate incorrect use of +-- the library, and the documentation for those data constructors calls +-- this out. The others wrap 'TLSError' with some kind of context to explain +-- when the exception occurred. +data TLSException + = -- | Early termination exception with the reason and the error associated + Terminated Bool String TLSError + | -- | Handshake failed for the reason attached. + HandshakeFailed TLSError + | -- | Failure occurred while sending or receiving data after the + -- TLS handshake succeeded. + PostHandshake TLSError + | -- | Lifts a 'TLSError' into 'TLSException' without provided any context + -- around when the error happened. + Uncontextualized TLSError + | -- | Usage error when the connection has not been established + -- and the user is trying to send or receive data. + -- Indicates that this library has been used incorrectly. + ConnectionNotEstablished + | -- | Expected that a TLS handshake had already taken place, but no TLS + -- handshake had occurred. + -- Indicates that this library has been used incorrectly. + MissingHandshake + deriving (Show, Eq, Typeable) + +instance Exception TLSException + +---------------------------------------------------------------- + +newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern AlertLevel_Warning :: AlertLevel +pattern AlertLevel_Warning = AlertLevel 1 +pattern AlertLevel_Fatal :: AlertLevel +pattern AlertLevel_Fatal = AlertLevel 2 + +instance Show AlertLevel where + show AlertLevel_Warning = "AlertLevel_Warning" + show AlertLevel_Fatal = "AlertLevel_Fatal" + show (AlertLevel x) = "AlertLevel " ++ show x +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +newtype AlertDescription = AlertDescription {fromAlertDescription :: Word8} + deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern CloseNotify :: AlertDescription +pattern CloseNotify = AlertDescription 0 +pattern UnexpectedMessage :: AlertDescription +pattern UnexpectedMessage = AlertDescription 10 +pattern BadRecordMac :: AlertDescription +pattern BadRecordMac = AlertDescription 20 +pattern DecryptionFailed :: AlertDescription +pattern DecryptionFailed = AlertDescription 21 +pattern RecordOverflow :: AlertDescription +pattern RecordOverflow = AlertDescription 22 +pattern DecompressionFailure :: AlertDescription +pattern DecompressionFailure = AlertDescription 30 +pattern HandshakeFailure :: AlertDescription +pattern HandshakeFailure = AlertDescription 40 +pattern BadCertificate :: AlertDescription +pattern BadCertificate = AlertDescription 42 +pattern UnsupportedCertificate :: AlertDescription +pattern UnsupportedCertificate = AlertDescription 43 +pattern CertificateRevoked :: AlertDescription +pattern CertificateRevoked = AlertDescription 44 +pattern CertificateExpired :: AlertDescription +pattern CertificateExpired = AlertDescription 45 +pattern CertificateUnknown :: AlertDescription +pattern CertificateUnknown = AlertDescription 46 +pattern IllegalParameter :: AlertDescription +pattern IllegalParameter = AlertDescription 47 +pattern UnknownCa :: AlertDescription +pattern UnknownCa = AlertDescription 48 +pattern AccessDenied :: AlertDescription +pattern AccessDenied = AlertDescription 49 +pattern DecodeError :: AlertDescription +pattern DecodeError = AlertDescription 50 +pattern DecryptError :: AlertDescription +pattern DecryptError = AlertDescription 51 +pattern ExportRestriction :: AlertDescription +pattern ExportRestriction = AlertDescription 60 +pattern ProtocolVersion :: AlertDescription +pattern ProtocolVersion = AlertDescription 70 +pattern InsufficientSecurity :: AlertDescription +pattern InsufficientSecurity = AlertDescription 71 +pattern InternalError :: AlertDescription +pattern InternalError = AlertDescription 80 +pattern InappropriateFallback :: AlertDescription +pattern InappropriateFallback = AlertDescription 86 -- RFC7507 +pattern UserCanceled :: AlertDescription +pattern UserCanceled = AlertDescription 90 +pattern NoRenegotiation :: AlertDescription +pattern NoRenegotiation = AlertDescription 100 +pattern MissingExtension :: AlertDescription +pattern MissingExtension = AlertDescription 109 +pattern UnsupportedExtension :: AlertDescription +pattern UnsupportedExtension = AlertDescription 110 +pattern CertificateUnobtainable :: AlertDescription +pattern CertificateUnobtainable = AlertDescription 111 +pattern UnrecognizedName :: AlertDescription +pattern UnrecognizedName = AlertDescription 112 +pattern BadCertificateStatusResponse :: AlertDescription +pattern BadCertificateStatusResponse = AlertDescription 113 +pattern BadCertificateHashValue :: AlertDescription +pattern BadCertificateHashValue = AlertDescription 114 +pattern UnknownPskIdentity :: AlertDescription +pattern UnknownPskIdentity = AlertDescription 115 +pattern CertificateRequired :: AlertDescription +pattern CertificateRequired = AlertDescription 116 +pattern GeneralError :: AlertDescription +pattern GeneralError = AlertDescription 117 +pattern NoApplicationProtocol :: AlertDescription +pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301 + +instance Show AlertDescription where + show CloseNotify = "CloseNotify" + show UnexpectedMessage = "UnexpectedMessage" + show BadRecordMac = "BadRecordMac" + show DecryptionFailed = "DecryptionFailed" + show RecordOverflow = "RecordOverflow" + show DecompressionFailure = "DecompressionFailure" + show HandshakeFailure = "HandshakeFailure" + show BadCertificate = "BadCertificate" + show UnsupportedCertificate = "UnsupportedCertificate" + show CertificateRevoked = "CertificateRevoked" + show CertificateExpired = "CertificateExpired" + show CertificateUnknown = "CertificateUnknown" + show IllegalParameter = "IllegalParameter" + show UnknownCa = "UnknownCa" + show AccessDenied = "AccessDenied" + show DecodeError = "DecodeError" + show DecryptError = "DecryptError" + show ExportRestriction = "ExportRestriction" + show ProtocolVersion = "ProtocolVersion" + show InsufficientSecurity = "InsufficientSecurity" + show InternalError = "InternalError" + show InappropriateFallback = "InappropriateFallback" + show UserCanceled = "UserCanceled" + show NoRenegotiation = "NoRenegotiation" + show MissingExtension = "MissingExtension" + show UnsupportedExtension = "UnsupportedExtension" + show CertificateUnobtainable = "CertificateUnobtainable" + show UnrecognizedName = "UnrecognizedName" + show BadCertificateStatusResponse = "BadCertificateStatusResponse" + show BadCertificateHashValue = "BadCertificateHashValue" + show UnknownPskIdentity = "UnknownPskIdentity" + show CertificateRequired = "CertificateRequired" + show GeneralError = "GeneralError" + show NoApplicationProtocol = "NoApplicationProtocol" + show (AlertDescription x) = "AlertDescription " ++ show x +{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -3,10 +3,61 @@ -- | Basic extensions are defined in RFC 6066 module Network.TLS.Extension ( - Extension (..), - supportedExtensions, + -- * Extension identifiers + ExtensionID ( + .., + EID_ServerName, + EID_MaxFragmentLength, + EID_ClientCertificateUrl, + EID_TrustedCAKeys, + EID_TruncatedHMAC, + EID_StatusRequest, + EID_UserMapping, + EID_ClientAuthz, + EID_ServerAuthz, + EID_CertType, + EID_SupportedGroups, + EID_EcPointFormats, + EID_SRP, + EID_SignatureAlgorithms, + EID_SRTP, + EID_Heartbeat, + EID_ApplicationLayerProtocolNegotiation, + EID_StatusRequestv2, + EID_SignedCertificateTimestamp, + EID_ClientCertificateType, + EID_ServerCertificateType, + EID_Padding, + EID_EncryptThenMAC, + EID_ExtendedMainSecret, + EID_SessionTicket, + EID_PreSharedKey, + EID_EarlyData, + EID_SupportedVersions, + EID_Cookie, + EID_PskKeyExchangeModes, + EID_CertificateAuthorities, + EID_OidFilters, + EID_PostHandshakeAuth, + EID_SignatureAlgorithmsCert, + EID_KeyShare, + EID_QuicTransportParameters, + EID_SecureRenegotiation + ), definedExtensions, - -- all implemented extensions + supportedExtensions, + + -- * Extension raw + ExtensionRaw (..), + toExtensionRaw, + extensionLookup, + lookupAndDecode, + lookupAndDecodeAndDo, + + -- * Class + Extension (..), + + -- * Extensions ServerNameType (..), ServerName (..), MaxFragmentLength (..), @@ -46,13 +97,14 @@ CertificateAuthorities (..), ) where +import qualified Control.Exception as E import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC +import Data.X509 (DistinguishedName) import Network.TLS.Crypto.Types -import Network.TLS.Struct -import Network.TLS.Types (HostName, Ticket) - +import Network.TLS.Error +import Network.TLS.HashAndSignature import Network.TLS.Imports import Network.TLS.Packet ( getBinaryVersion, @@ -62,8 +114,133 @@ putDNames, putSignatureHashAlgorithm, ) +import Network.TLS.Types (HostName, Ticket, Version) import Network.TLS.Wire +---------------------------------------------------------------- +-- Extension identifiers + +-- | Identifier of a TLS extension. +-- +newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern EID_ServerName :: ExtensionID -- RFC6066 +pattern EID_ServerName = ExtensionID 0x0 +pattern EID_MaxFragmentLength :: ExtensionID -- RFC6066 +pattern EID_MaxFragmentLength = ExtensionID 0x1 +pattern EID_ClientCertificateUrl :: ExtensionID -- RFC6066 +pattern EID_ClientCertificateUrl = ExtensionID 0x2 +pattern EID_TrustedCAKeys :: ExtensionID -- RFC6066 +pattern EID_TrustedCAKeys = ExtensionID 0x3 +pattern EID_TruncatedHMAC :: ExtensionID -- RFC6066 +pattern EID_TruncatedHMAC = ExtensionID 0x4 +pattern EID_StatusRequest :: ExtensionID -- RFC6066 +pattern EID_StatusRequest = ExtensionID 0x5 +pattern EID_UserMapping :: ExtensionID -- RFC4681 +pattern EID_UserMapping = ExtensionID 0x6 +pattern EID_ClientAuthz :: ExtensionID -- RFC5878 +pattern EID_ClientAuthz = ExtensionID 0x7 +pattern EID_ServerAuthz :: ExtensionID -- RFC5878 +pattern EID_ServerAuthz = ExtensionID 0x8 +pattern EID_CertType :: ExtensionID -- RFC6091 +pattern EID_CertType = ExtensionID 0x9 +pattern EID_SupportedGroups :: ExtensionID -- RFC8422,8446 +pattern EID_SupportedGroups = ExtensionID 0xa +pattern EID_EcPointFormats :: ExtensionID -- RFC4492 +pattern EID_EcPointFormats = ExtensionID 0xb +pattern EID_SRP :: ExtensionID -- RFC5054 +pattern EID_SRP = ExtensionID 0xc +pattern EID_SignatureAlgorithms :: ExtensionID -- RFC5246,8446 +pattern EID_SignatureAlgorithms = ExtensionID 0xd +pattern EID_SRTP :: ExtensionID -- RFC5764 +pattern EID_SRTP = ExtensionID 0xe +pattern EID_Heartbeat :: ExtensionID -- RFC6520 +pattern EID_Heartbeat = ExtensionID 0xf +pattern EID_ApplicationLayerProtocolNegotiation :: ExtensionID -- RFC7301 +pattern EID_ApplicationLayerProtocolNegotiation = ExtensionID 0x10 +pattern EID_StatusRequestv2 :: ExtensionID -- RFC6961 +pattern EID_StatusRequestv2 = ExtensionID 0x11 +pattern EID_SignedCertificateTimestamp :: ExtensionID -- RFC6962 +pattern EID_SignedCertificateTimestamp = ExtensionID 0x12 +pattern EID_ClientCertificateType :: ExtensionID -- RFC7250 +pattern EID_ClientCertificateType = ExtensionID 0x13 +pattern EID_ServerCertificateType :: ExtensionID -- RFC7250 +pattern EID_ServerCertificateType = ExtensionID 0x14 +pattern EID_Padding :: ExtensionID -- RFC5246 +pattern EID_Padding = ExtensionID 0x15 +pattern EID_EncryptThenMAC :: ExtensionID -- RFC7366 +pattern EID_EncryptThenMAC = ExtensionID 0x16 +pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627 +pattern EID_ExtendedMainSecret = ExtensionID 0x17 +pattern EID_SessionTicket :: ExtensionID -- RFC4507 +pattern EID_SessionTicket = ExtensionID 0x23 +pattern EID_PreSharedKey :: ExtensionID -- RFC8446 +pattern EID_PreSharedKey = ExtensionID 0x29 +pattern EID_EarlyData :: ExtensionID -- RFC8446 +pattern EID_EarlyData = ExtensionID 0x2a +pattern EID_SupportedVersions :: ExtensionID -- RFC8446 +pattern EID_SupportedVersions = ExtensionID 0x2b +pattern EID_Cookie :: ExtensionID -- RFC8446 +pattern EID_Cookie = ExtensionID 0x2c +pattern EID_PskKeyExchangeModes :: ExtensionID -- RFC8446 +pattern EID_PskKeyExchangeModes = ExtensionID 0x2d +pattern EID_CertificateAuthorities :: ExtensionID -- RFC8446 +pattern EID_CertificateAuthorities = ExtensionID 0x2f +pattern EID_OidFilters :: ExtensionID -- RFC8446 +pattern EID_OidFilters = ExtensionID 0x30 +pattern EID_PostHandshakeAuth :: ExtensionID -- RFC8446 +pattern EID_PostHandshakeAuth = ExtensionID 0x31 +pattern EID_SignatureAlgorithmsCert :: ExtensionID -- RFC8446 +pattern EID_SignatureAlgorithmsCert = ExtensionID 0x32 +pattern EID_KeyShare :: ExtensionID -- RFC8446 +pattern EID_KeyShare = ExtensionID 0x33 +pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001 +pattern EID_QuicTransportParameters = ExtensionID 0x39 +pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746 +pattern EID_SecureRenegotiation = ExtensionID 0xff01 + +instance Show ExtensionID where + show EID_ServerName = "ServerName" + show EID_MaxFragmentLength = "MaxFragmentLength" + show EID_ClientCertificateUrl = "ClientCertificateUrl" + show EID_TrustedCAKeys = "TrustedCAKeys" + show EID_TruncatedHMAC = "TruncatedHMAC" + show EID_StatusRequest = "StatusRequest" + show EID_UserMapping = "UserMapping" + show EID_ClientAuthz = "ClientAuthz" + show EID_ServerAuthz = "ServerAuthz" + show EID_CertType = "CertType" + show EID_SupportedGroups = "SupportedGroups" + show EID_EcPointFormats = "EcPointFormats" + show EID_SRP = "SRP" + show EID_SignatureAlgorithms = "SignatureAlgorithms" + show EID_SRTP = "SRTP" + show EID_Heartbeat = "Heartbeat" + show EID_ApplicationLayerProtocolNegotiation = "ApplicationLayerProtocolNegotiation" + show EID_StatusRequestv2 = "StatusRequestv2" + show EID_SignedCertificateTimestamp = "SignedCertificateTimestamp" + show EID_ClientCertificateType = "ClientCertificateType" + show EID_ServerCertificateType = "ServerCertificateType" + show EID_Padding = "Padding" + show EID_EncryptThenMAC = "EncryptThenMAC" + show EID_ExtendedMainSecret = "ExtendedMainSecret" + show EID_SessionTicket = "SessionTicket" + show EID_PreSharedKey = "PreSharedKey" + show EID_EarlyData = "EarlyData" + show EID_SupportedVersions = "SupportedVersions" + show EID_Cookie = "Cookie" + show EID_PskKeyExchangeModes = "PskKeyExchangeModes" + show EID_CertificateAuthorities = "CertificateAuthorities" + show EID_OidFilters = "OidFilters" + show EID_PostHandshakeAuth = "PostHandshakeAuth" + show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert" + show EID_KeyShare = "KeyShare" + show EID_QuicTransportParameters = "QuicTransportParameters" + show EID_SecureRenegotiation = "SecureRenegotiation" + show (ExtensionID x) = "ExtensionID " ++ show x +{- FOURMOLU_ENABLE -} + ------------------------------------------------------------ definedExtensions :: [ExtensionID] @@ -98,37 +275,127 @@ , EID_SupportedVersions , EID_Cookie , EID_PskKeyExchangeModes - , EID_KeyShare - , EID_SignatureAlgorithmsCert , EID_CertificateAuthorities - , EID_SecureRenegotiation + , EID_OidFilters + , EID_PostHandshakeAuth + , EID_SignatureAlgorithmsCert + , EID_KeyShare , EID_QuicTransportParameters + , EID_SecureRenegotiation ] -- | all supported extensions by the implementation +{- FOURMOLU_DISABLE -} supportedExtensions :: [ExtensionID] supportedExtensions = - [ EID_ServerName - , EID_MaxFragmentLength - , EID_ApplicationLayerProtocolNegotiation - , EID_ExtendedMainSecret - , EID_SecureRenegotiation - , EID_SupportedGroups - , EID_EcPointFormats - , EID_SignatureAlgorithms - , EID_SignatureAlgorithmsCert - , EID_KeyShare - , EID_PreSharedKey - , EID_EarlyData - , EID_SupportedVersions - , EID_Cookie - , EID_PskKeyExchangeModes - , EID_CertificateAuthorities - , EID_QuicTransportParameters + [ 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_SessionTicket -- 0x23 + , EID_PreSharedKey -- 0x29 + , EID_EarlyData -- 0x2a + , EID_SupportedVersions -- 0x2b + , EID_Cookie -- 0x2c + , EID_PskKeyExchangeModes -- 0x2d + , EID_CertificateAuthorities -- 0x2f + , EID_PostHandshakeAuth -- 0x31 + , EID_SignatureAlgorithmsCert -- 0x32 + , EID_KeyShare -- 0x33 + , EID_QuicTransportParameters -- 0x39 + , EID_SecureRenegotiation -- 0xff01 ] +{- FOURMOLU_ENABLE -} +---------------------------------------------------------------- + +-- | The raw content of a TLS extension. +data ExtensionRaw = ExtensionRaw ExtensionID ByteString + deriving (Eq) + +instance Show ExtensionRaw where + show (ExtensionRaw eid@EID_ServerName bs) = showExtensionRaw eid bs decodeServerName + show (ExtensionRaw eid@EID_MaxFragmentLength bs) = showExtensionRaw eid bs decodeMaxFragmentLength + show (ExtensionRaw eid@EID_SupportedGroups bs) = showExtensionRaw eid bs decodeSupportedGroups + show (ExtensionRaw eid@EID_EcPointFormats bs) = showExtensionRaw eid bs decodeEcPointFormatsSupported + show (ExtensionRaw eid@EID_SignatureAlgorithms bs) = showExtensionRaw eid bs decodeSignatureAlgorithms + 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_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_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_SecureRenegotiation bs) = show eid ++ " " ++ showBytesHex bs + show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs + +showExtensionRaw + :: Show a => ExtensionID -> ByteString -> (ByteString -> Maybe a) -> String +showExtensionRaw eid bs decode = case decode bs of + Nothing -> show eid ++ " broken" + Just x -> show x + +toExtensionRaw :: Extension e => e -> ExtensionRaw +toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) + +extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString +extensionLookup toFind exts = extract <$> find idEq exts + where + extract (ExtensionRaw _ content) = content + idEq (ExtensionRaw eid _) = eid == toFind + +lookupAndDecode + :: Extension e + => ExtensionID + -> MessageType + -> [ExtensionRaw] + -> a + -> (e -> a) + -> a +lookupAndDecode eid msgtyp exts defval conv = case extensionLookup eid exts of + Nothing -> defval + Just bs -> case extensionDecode msgtyp bs of + Nothing -> + E.throw $ + Uncontextualized $ + Error_Protocol ("Illegal " ++ show eid) DecodeError + Just val -> conv val + +lookupAndDecodeAndDo + :: Extension a + => ExtensionID + -> MessageType + -> [ExtensionRaw] + -> IO b + -> (a -> IO b) + -> IO b +lookupAndDecodeAndDo eid msgtyp exts defAction action = case extensionLookup eid exts of + Nothing -> defAction + Just bs -> case extensionDecode msgtyp bs of + Nothing -> + E.throwIO $ + Uncontextualized $ + Error_Protocol ("Illegal " ++ show eid) DecodeError + Just val -> action val + ------------------------------------------------------------ +-- | Extension class to transform bytes to and from a high level Extension type. +class Extension a where + extensionID :: a -> ExtensionID + extensionDecode :: MessageType -> ByteString -> Maybe a + extensionEncode :: a -> ByteString + data MessageType = MsgTClientHello | MsgTServerHello @@ -138,12 +405,6 @@ | MsgTCertificateRequest deriving (Eq, Show) --- | Extension class to transform bytes to and from a high level Extension type. -class Extension a where - extensionID :: a -> ExtensionID - extensionDecode :: MessageType -> ByteString -> Maybe a - extensionEncode :: a -> ByteString - ------------------------------------------------------------ -- | Server Name extension including the name type and the associated name. @@ -154,10 +415,18 @@ data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString) - deriving (Show, Eq) + deriving (Eq) +instance Show ServerNameType where + show (ServerNameHostName host) = "\"" ++ host ++ "\"" + show (ServerNameOther (w, _)) = "(" ++ show w ++ ", )" + instance Extension ServerName where extensionID _ = EID_ServerName + + -- dirty hack for servers + extensionEncode (ServerName []) = "" + -- for clients extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion @@ -168,10 +437,12 @@ extensionDecode _ = error "extensionDecode: ServerName" decodeServerName :: ByteString -> Maybe ServerName -decodeServerName = runGetMaybe $ do - len <- fromIntegral <$> getWord16 - ServerName <$> getList len getServerName +decodeServerName "" = Just $ ServerName [] -- dirty hack for servers +decodeServerName bs = runGetMaybe decode bs where + decode = do + len <- fromIntegral <$> getWord16 + ServerName <$> getList len getServerName getServerName = do ty <- getWord8 snameParsed <- getOpaque16 @@ -228,64 +499,6 @@ ------------------------------------------------------------ --- | Secure Renegotiation -data SecureRenegotiation = SecureRenegotiation ByteString ByteString - deriving (Show, Eq) - -instance Extension SecureRenegotiation where - extensionID _ = EID_SecureRenegotiation - extensionEncode (SecureRenegotiation cvd svd) = - runPut $ putOpaque8 (cvd `B.append` svd) - extensionDecode msgtype = runGetMaybe $ do - opaque <- getOpaque8 - case msgtype of - MsgTServerHello -> - let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque - in return $ SecureRenegotiation cvd svd - MsgTClientHello -> return $ SecureRenegotiation opaque "" - _ -> error "extensionDecode: SecureRenegotiation" - ------------------------------------------------------------- - --- | Application Layer Protocol Negotiation (ALPN) -newtype ApplicationLayerProtocolNegotiation - = ApplicationLayerProtocolNegotiation [ByteString] - deriving (Show, Eq) - -instance Extension ApplicationLayerProtocolNegotiation where - extensionID _ = EID_ApplicationLayerProtocolNegotiation - extensionEncode (ApplicationLayerProtocolNegotiation bytes) = - runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes - extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation - extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation - extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation - extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" - -decodeApplicationLayerProtocolNegotiation - :: ByteString -> Maybe ApplicationLayerProtocolNegotiation -decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do - len <- getWord16 - ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN - where - getALPN = do - alpnParsed <- getOpaque8 - let alpn = B.copy alpnParsed - return (B.length alpn + 1, alpn) - ------------------------------------------------------------- - --- | Extended Main Secret -data ExtendedMainSecret = ExtendedMainSecret deriving (Show, Eq) - -instance Extension ExtendedMainSecret where - extensionID _ = EID_ExtendedMainSecret - extensionEncode ExtendedMainSecret = B.empty - extensionDecode MsgTClientHello _ = Just ExtendedMainSecret - extensionDecode MsgTServerHello _ = Just ExtendedMainSecret - extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret" - ------------------------------------------------------------- - newtype SupportedGroups = SupportedGroups [Group] deriving (Show, Eq) -- on decode, filter all unknown curves @@ -337,17 +550,28 @@ ------------------------------------------------------------ -newtype SessionTicket = SessionTicket Ticket +newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show, Eq) --- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A -instance Extension SessionTicket where - extensionID _ = EID_SessionTicket - extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket - extensionDecode MsgTClientHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes) - extensionDecode MsgTServerHello = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes) - extensionDecode _ = error "extensionDecode: SessionTicket" +instance Extension SignatureAlgorithms where + extensionID _ = EID_SignatureAlgorithms + extensionEncode (SignatureAlgorithms algs) = + runPut $ + putWord16 (fromIntegral (length algs * 2)) + >> mapM_ putSignatureHashAlgorithm algs + extensionDecode MsgTClientHello = decodeSignatureAlgorithms + extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms + extensionDecode _ = error "extensionDecode: SignatureAlgorithms" +decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms +decodeSignatureAlgorithms = runGetMaybe $ do + len <- getWord16 + sas <- + getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + leftoverLen <- remaining + when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length" + return $ SignatureAlgorithms sas + ------------------------------------------------------------ newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq) @@ -379,165 +603,58 @@ ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] - deriving (Show, Eq) - -instance Extension SignatureAlgorithms where - extensionID _ = EID_SignatureAlgorithms - extensionEncode (SignatureAlgorithms algs) = - runPut $ - putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs - extensionDecode MsgTClientHello = decodeSignatureAlgorithms - extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms - extensionDecode _ = error "extensionDecode: SignatureAlgorithms" - -decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms -decodeSignatureAlgorithms = runGetMaybe $ do - len <- getWord16 - sas <- - getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) - leftoverLen <- remaining - when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length" - return $ SignatureAlgorithms sas - ------------------------------------------------------------- - -data PostHandshakeAuth = PostHandshakeAuth deriving (Show, Eq) - -instance Extension PostHandshakeAuth where - extensionID _ = EID_PostHandshakeAuth - extensionEncode _ = B.empty - extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth - extensionDecode _ = error "extensionDecode: PostHandshakeAuth" - ------------------------------------------------------------- - -newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] +-- | Application Layer Protocol Negotiation (ALPN) +newtype ApplicationLayerProtocolNegotiation + = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show, Eq) -instance Extension SignatureAlgorithmsCert where - extensionID _ = EID_SignatureAlgorithmsCert - extensionEncode (SignatureAlgorithmsCert algs) = - runPut $ - putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs - extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert - extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert - extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" +instance Extension ApplicationLayerProtocolNegotiation where + extensionID _ = EID_ApplicationLayerProtocolNegotiation + extensionEncode (ApplicationLayerProtocolNegotiation bytes) = + runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes + extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation + extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation + extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation + extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" -decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert -decodeSignatureAlgorithmsCert = runGetMaybe $ do +decodeApplicationLayerProtocolNegotiation + :: ByteString -> Maybe ApplicationLayerProtocolNegotiation +decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do len <- getWord16 - SignatureAlgorithmsCert - <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN + where + getALPN = do + alpnParsed <- getOpaque8 + let alpn = B.copy alpnParsed + return (B.length alpn + 1, alpn) ------------------------------------------------------------ -data SupportedVersions - = SupportedVersionsClientHello [Version] - | SupportedVersionsServerHello Version - deriving (Show, Eq) +-- | Extended Main Secret +data ExtendedMainSecret = ExtendedMainSecret deriving (Show, Eq) -instance Extension SupportedVersions where - extensionID _ = EID_SupportedVersions - extensionEncode (SupportedVersionsClientHello vers) = runPut $ do - putWord8 (fromIntegral (length vers * 2)) - mapM_ putBinaryVersion vers - 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 _ = error "extensionDecode: SupportedVersionsServerHello" +instance Extension ExtendedMainSecret where + extensionID _ = EID_ExtendedMainSecret + extensionEncode ExtendedMainSecret = B.empty + extensionDecode MsgTClientHello "" = Just ExtendedMainSecret + extensionDecode MsgTServerHello "" = Just ExtendedMainSecret + extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret" ------------------------------------------------------------ -data KeyShareEntry = KeyShareEntry - { keyShareEntryGroup :: Group - , keyShareEntryKeyExchange :: ByteString - } - deriving (Show, Eq) - -getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) -getKeyShareEntry = do - grp <- Group <$> getWord16 - l <- fromIntegral <$> getWord16 - key <- getBytes l - let len = l + 4 - return (len, Just $ KeyShareEntry grp key) - -putKeyShareEntry :: KeyShareEntry -> Put -putKeyShareEntry (KeyShareEntry (Group grp) key) = do - putWord16 grp - putWord16 $ fromIntegral $ B.length key - putBytes key - -data KeyShare - = KeyShareClientHello [KeyShareEntry] - | KeyShareServerHello KeyShareEntry - | KeyShareHRR Group +newtype SessionTicket = SessionTicket Ticket deriving (Show, Eq) -instance Extension KeyShare where - extensionID _ = EID_KeyShare - extensionEncode (KeyShareClientHello kses) = runPut $ do - let len = sum [B.length key + 4 | KeyShareEntry _ key <- kses] - putWord16 $ fromIntegral len - 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 _ = error "extensionDecode: KeyShare" - ------------------------------------------------------------- - -newtype PskKexMode = PskKexMode {fromPskKexMode :: Word8} deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern PSK_KE :: PskKexMode -pattern PSK_KE = PskKexMode 0 -pattern PSK_DHE_KE :: PskKexMode -pattern PSK_DHE_KE = PskKexMode 1 - -instance Show PskKexMode where - show PSK_KE = "PSK_KE" - show PSK_DHE_KE = "PSK_DHE_KE" - show (PskKexMode x) = "PskKexMode " ++ show x -{- FOURMOLU_ENABLE -} - -newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] - deriving (Eq, Show) +-- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A +instance Extension SessionTicket where + extensionID _ = EID_SessionTicket + extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket + extensionDecode MsgTClientHello = decodeSessionTicket + extensionDecode MsgTServerHello = decodeSessionTicket + extensionDecode _ = error "extensionDecode: SessionTicket" -instance Extension PskKeyExchangeModes where - extensionID _ = EID_PskKeyExchangeModes - extensionEncode (PskKeyExchangeModes pkms) = - runPut $ - putWords8 $ - map fromPskKexMode pkms - extensionDecode MsgTClientHello = - runGetMaybe $ - PskKeyExchangeModes . map PskKexMode <$> getWords8 - extensionDecode _ = error "extensionDecode: PskKeyExchangeModes" +decodeSessionTicket :: ByteString -> Maybe SessionTicket +decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes) ------------------------------------------------------------ @@ -602,6 +719,32 @@ ------------------------------------------------------------ +data SupportedVersions + = SupportedVersionsClientHello [Version] + | SupportedVersionsServerHello Version + deriving (Show, Eq) + +instance Extension SupportedVersions where + extensionID _ = EID_SupportedVersions + extensionEncode (SupportedVersionsClientHello vers) = runPut $ do + putWord8 (fromIntegral (length vers * 2)) + mapM_ putBinaryVersion vers + 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 _ = error "extensionDecode: SupportedVersionsServerHello" + +------------------------------------------------------------ + newtype Cookie = Cookie ByteString deriving (Eq, Show) instance Extension Cookie where @@ -612,6 +755,39 @@ ------------------------------------------------------------ +newtype PskKexMode = PskKexMode {fromPskKexMode :: Word8} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern PSK_KE :: PskKexMode +pattern PSK_KE = PskKexMode 0 +pattern PSK_DHE_KE :: PskKexMode +pattern PSK_DHE_KE = PskKexMode 1 + +instance Show PskKexMode where + show PSK_KE = "PSK_KE" + show PSK_DHE_KE = "PSK_DHE_KE" + show (PskKexMode x) = "PskKexMode " ++ show x +{- FOURMOLU_ENABLE -} + +newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] + deriving (Eq, Show) + +instance Extension PskKeyExchangeModes where + extensionID _ = EID_PskKeyExchangeModes + extensionEncode (PskKeyExchangeModes pkms) = + runPut $ + putWords8 $ + map fromPskKexMode pkms + extensionDecode MsgTClientHello = decodePskKeyExchangeModes + extensionDecode _ = error "extensionDecode: PskKeyExchangeModes" + +decodePskKeyExchangeModes :: ByteString -> Maybe PskKeyExchangeModes +decodePskKeyExchangeModes = + runGetMaybe $ + PskKeyExchangeModes . map PskKexMode <$> getWords8 + +------------------------------------------------------------ + newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName] deriving (Eq, Show) @@ -620,8 +796,111 @@ extensionEncode (CertificateAuthorities names) = runPut $ putDNames names - extensionDecode MsgTClientHello = - runGetMaybe (CertificateAuthorities <$> getDNames) - extensionDecode MsgTCertificateRequest = - runGetMaybe (CertificateAuthorities <$> getDNames) + extensionDecode MsgTClientHello = decodeCertificateAuthorities + extensionDecode MsgTCertificateRequest = decodeCertificateAuthorities extensionDecode _ = error "extensionDecode: CertificateAuthorities" + +decodeCertificateAuthorities :: ByteString -> Maybe CertificateAuthorities +decodeCertificateAuthorities = + runGetMaybe (CertificateAuthorities <$> getDNames) + +------------------------------------------------------------ + +data PostHandshakeAuth = PostHandshakeAuth deriving (Show, Eq) + +instance Extension PostHandshakeAuth where + extensionID _ = EID_PostHandshakeAuth + extensionEncode _ = B.empty + extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth + extensionDecode _ = error "extensionDecode: PostHandshakeAuth" + +------------------------------------------------------------ + +newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] + deriving (Show, Eq) + +instance Extension SignatureAlgorithmsCert where + extensionID _ = EID_SignatureAlgorithmsCert + extensionEncode (SignatureAlgorithmsCert algs) = + runPut $ + putWord16 (fromIntegral (length algs * 2)) + >> mapM_ putSignatureHashAlgorithm algs + extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert + extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert + extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" + +decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert +decodeSignatureAlgorithmsCert = runGetMaybe $ do + len <- getWord16 + SignatureAlgorithmsCert + <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + +------------------------------------------------------------ + +data KeyShareEntry = KeyShareEntry + { keyShareEntryGroup :: Group + , keyShareEntryKeyExchange :: ByteString + } + deriving (Show, Eq) + +getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) +getKeyShareEntry = do + grp <- Group <$> getWord16 + l <- fromIntegral <$> getWord16 + key <- getBytes l + let len = l + 4 + return (len, Just $ KeyShareEntry grp key) + +putKeyShareEntry :: KeyShareEntry -> Put +putKeyShareEntry (KeyShareEntry (Group grp) key) = do + putWord16 grp + putWord16 $ fromIntegral $ B.length key + putBytes key + +data KeyShare + = KeyShareClientHello [KeyShareEntry] + | KeyShareServerHello KeyShareEntry + | KeyShareHRR Group + deriving (Show, Eq) + +instance Extension KeyShare where + extensionID _ = EID_KeyShare + extensionEncode (KeyShareClientHello kses) = runPut $ do + let len = sum [B.length key + 4 | KeyShareEntry _ key <- kses] + putWord16 $ fromIntegral len + 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 _ = error "extensionDecode: KeyShare" + +------------------------------------------------------------ + +-- | Secure Renegotiation +data SecureRenegotiation = SecureRenegotiation ByteString ByteString + deriving (Show, Eq) + +instance Extension SecureRenegotiation where + extensionID _ = EID_SecureRenegotiation + extensionEncode (SecureRenegotiation cvd svd) = + runPut $ putOpaque8 (cvd `B.append` svd) + extensionDecode MsgTClientHello = runGetMaybe $ do + opaque <- getOpaque8 + return $ SecureRenegotiation opaque "" + extensionDecode MsgTServerHello = runGetMaybe $ do + opaque <- getOpaque8 + let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque + return $ SecureRenegotiation cvd svd + extensionDecode _ = error "extensionDecode: SecureRenegotiation" diff --git a/Network/TLS/Extension.hs-boot b/Network/TLS/Extension.hs-boot new file mode 100644 --- /dev/null +++ b/Network/TLS/Extension.hs-boot @@ -0,0 +1,22 @@ +-- This is a breaker for cyclic imports: +-- +-- - Network.TLS.Extension imports Network.TLS.Struct +-- - Network.TLS.Extension imports Network.TLS.Packet +-- +-- - Network.TLS.Struct imports Network.TLS.Extension +-- +-- - Network.TLS.Packet imports Network.TLS.Struct +-- +-- Originally, ExtensionRaw was defined in Network.TLS.Struct and no +-- cyclic imports exist. It is moved into Network.TLS.Extension for +-- pretty-printing, so the cyclic imports happen. +module Network.TLS.Extension where + +import Data.ByteString +import Data.Word + +data ExtensionRaw = ExtensionRaw ExtensionID ByteString +instance Eq ExtensionRaw +instance Show ExtensionRaw + +newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -1,5 +1,5 @@ module Network.TLS.Extra.Cipher ( - -- * cipher suite + -- * Cipher suite ciphersuite_default, ciphersuite_default_det, ciphersuite_all, @@ -8,33 +8,72 @@ ciphersuite_strong_det, ciphersuite_dhe_rsa, - -- * individual ciphers + -- * Individual ciphers + + -- ** RFC 5288 + cipher_DHE_RSA_WITH_AES_128_GCM_SHA256, + cipher_DHE_RSA_WITH_AES_256_GCM_SHA384, + + -- ** RFC 8446 + cipher13_AES_128_GCM_SHA256, + cipher13_AES_256_GCM_SHA384, + cipher13_CHACHA20_POLY1305_SHA256, + cipher13_AES_128_CCM_SHA256, + cipher13_AES_128_CCM_8_SHA256, + + -- ** RFC 5289 + cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256, + cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, + cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256, + cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384, + + -- ** RFC 7251 + cipher_ECDHE_ECDSA_WITH_AES_128_CCM, + cipher_ECDHE_ECDSA_WITH_AES_256_CCM, + cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8, + cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8, + + -- ** RFC 7905 + cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, + cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + + -- * Deprecated names + + -- ** RFC 5288 cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384, - cipher_DHE_RSA_CHACHA20POLY1305_SHA256, + + -- ** RFC 8446 + cipher_TLS13_AES128GCM_SHA256, + cipher_TLS13_AES256GCM_SHA384, + cipher_TLS13_CHACHA20POLY1305_SHA256, + cipher_TLS13_AES128CCM_SHA256, + cipher_TLS13_AES128CCM8_SHA256, + + -- ** RFC 5289 + cipher_ECDHE_ECDSA_AES128GCM_SHA256, + cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384, - cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256, + + -- ** RFC 7251 cipher_ECDHE_ECDSA_AES128CCM_SHA256, - cipher_ECDHE_ECDSA_AES128CCM8_SHA256, - cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256, + cipher_ECDHE_ECDSA_AES128CCM8_SHA256, cipher_ECDHE_ECDSA_AES256CCM8_SHA256, - cipher_ECDHE_ECDSA_AES256GCM_SHA384, + + -- ** RFC 7905 + cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256, cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256, - -- TLS 1.3 - cipher_TLS13_AES128GCM_SHA256, - cipher_TLS13_AES256GCM_SHA384, - cipher_TLS13_CHACHA20POLY1305_SHA256, - cipher_TLS13_AES128CCM_SHA256, - cipher_TLS13_AES128CCM8_SHA256, + cipher_DHE_RSA_CHACHA20POLY1305_SHA256, ) where import qualified Data.ByteString as B import Data.Tuple (swap) import Network.TLS.Cipher -import Network.TLS.Types (Version (..)) +import Network.TLS.Types import Crypto.Cipher.AES import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 @@ -45,151 +84,6 @@ ---------------------------------------------------------------- -aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD -aes128ccm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes128ccm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) - -aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD -aes128ccm8 BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 8 - ) -aes128ccm8 BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in simpleDecrypt aeadIni ad d 8 - ) - -aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD -aes128gcm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes128gcm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES128 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) - -aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD -aes256ccm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes256ccm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) - -aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD -aes256ccm8 BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 8 - ) -aes256ccm8 BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 - aeadIni = noFail (aeadInit mode ctx nonce) - in simpleDecrypt aeadIni ad d 8 - ) - -aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD -aes256gcm BulkEncrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16 - ) -aes256gcm BulkDecrypt key = - let ctx = noFail (cipherInit key) :: AES256 - in ( \nonce d ad -> - let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16 - ) - -simpleDecrypt - :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag) -simpleDecrypt aeadIni header input taglen = (output, tag) - where - aead = aeadAppendHeader aeadIni header - (output, aeadFinal) = aeadDecrypt aead input - tag = aeadFinalize aeadFinal taglen - -noFail :: CryptoFailable a -> a -noFail = throwCryptoError - -chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD -chacha20poly1305 BulkEncrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in ( \input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.encrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag) - ) -chacha20poly1305 BulkDecrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in ( \input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.decrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag) - ) - ----------------------------------------------------------------- - -data CipherSet - = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm - | SetOther [Cipher] - --- Preference between AEAD ciphers having equivalent properties is based on --- hardware-acceleration support in the crypton implementation. -sortOptimized :: [CipherSet] -> [Cipher] -sortOptimized = concatMap f - where - f (SetAead gcm chacha ccm) - | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm - | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm - | otherwise = gcm ++ ccm ++ chacha - f (SetOther ciphers) = ciphers - --- Order which is deterministic but not optimized for the CPU. -sortDeterministic :: [CipherSet] -> [Cipher] -sortDeterministic = concatMap f - where - f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm - f (SetOther ciphers) = ciphers - -- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to -- weak. This choice of ciphersuites should satisfy most normal needs. For -- otherwise strong ciphers we make little distinction between AES128 and @@ -224,9 +118,9 @@ complement_all :: [Cipher] complement_all = - [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256 - , cipher_ECDHE_ECDSA_AES256CCM8_SHA256 - , cipher_TLS13_AES128CCM8_SHA256 + [ cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 + , cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 + , cipher13_AES_128_CCM_8_SHA256 ] -- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we @@ -248,30 +142,30 @@ sets_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256 SetAead - [cipher_ECDHE_ECDSA_AES256GCM_SHA384] - [cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256] - [cipher_ECDHE_ECDSA_AES256CCM_SHA256] + [cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384] + [cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256] + [cipher_ECDHE_ECDSA_WITH_AES_256_CCM] , SetAead - [cipher_ECDHE_ECDSA_AES128GCM_SHA256] + [cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256] [] - [cipher_ECDHE_ECDSA_AES128CCM_SHA256] + [cipher_ECDHE_ECDSA_WITH_AES_128_CCM] , SetAead - [cipher_ECDHE_RSA_AES256GCM_SHA384] - [cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256] + [cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384] + [cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256] [] , SetAead - [cipher_ECDHE_RSA_AES128GCM_SHA256] + [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] [] [] , -- TLS13 (listed at the end but version is negotiated first) SetAead - [cipher_TLS13_AES256GCM_SHA384] - [cipher_TLS13_CHACHA20POLY1305_SHA256] + [cipher13_AES_256_GCM_SHA384] + [cipher13_CHACHA20_POLY1305_SHA256] [] , SetAead - [cipher_TLS13_AES128GCM_SHA256] + [cipher13_AES_128_GCM_SHA256] [] - [cipher_TLS13_AES128CCM_SHA256] + [cipher13_AES_128_CCM_SHA256] ] -- | DHE-RSA cipher suite. This only includes ciphers bound specifically to @@ -280,110 +174,12 @@ -- @since 2.1.5 ciphersuite_dhe_rsa :: [Cipher] ciphersuite_dhe_rsa = - [ cipher_DHE_RSA_AES256GCM_SHA384 - , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 - , cipher_DHE_RSA_AES128GCM_SHA256 + [ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 ] ---------------------------------------------------------------- - -bulk_aes128ccm :: Bulk -bulk_aes128ccm = - Bulk - { bulkName = "AES128CCM" - , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 16 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes128ccm - } - -bulk_aes128ccm8 :: Bulk -bulk_aes128ccm8 = - Bulk - { bulkName = "AES128CCM8" - , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 8 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes128ccm8 - } - -bulk_aes128gcm :: Bulk -bulk_aes128gcm = - Bulk - { bulkName = "AES128GCM" - , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 16 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes128gcm - } - -bulk_aes256ccm :: Bulk -bulk_aes256ccm = - Bulk - { bulkName = "AES256CCM" - , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 16 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes256ccm - } - -bulk_aes256ccm8 :: Bulk -bulk_aes256ccm8 = - Bulk - { bulkName = "AES256CCM8" - , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 8 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes256ccm8 - } - -bulk_aes256gcm :: Bulk -bulk_aes256gcm = - Bulk - { bulkName = "AES256GCM" - , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN - , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length - , bulkExplicitIV = 8 - , bulkAuthTagLen = 16 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF aes256gcm - } - -bulk_chacha20poly1305 :: Bulk -bulk_chacha20poly1305 = - Bulk - { bulkName = "CHACHA20POLY1305" - , bulkKeySize = 32 - , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length - , bulkExplicitIV = 0 - , bulkAuthTagLen = 16 - , bulkBlockSize = 0 -- dummy, not used - , bulkF = BulkAeadF chacha20poly1305 - } - --- TLS13 bulks are same as TLS12 except they never have explicit IV -bulk_aes128gcm_13 :: Bulk -bulk_aes128gcm_13 = bulk_aes128gcm{bulkIVSize = 12, bulkExplicitIV = 0} - -bulk_aes256gcm_13 :: Bulk -bulk_aes256gcm_13 = bulk_aes256gcm{bulkIVSize = 12, bulkExplicitIV = 0} - -bulk_aes128ccm_13 :: Bulk -bulk_aes128ccm_13 = bulk_aes128ccm{bulkIVSize = 12, bulkExplicitIV = 0} - -bulk_aes128ccm8_13 :: Bulk -bulk_aes128ccm8_13 = bulk_aes128ccm8{bulkIVSize = 12, bulkExplicitIV = 0} - ---------------------------------------------------------------- -- A list of cipher suite is found from: @@ -392,8 +188,9 @@ ---------------------------------------------------------------- -- RFC 5288 -cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher -cipher_DHE_RSA_AES128GCM_SHA256 = +-- TLS_DHE_RSA_WITH_AES_128_GCM_SHA256 +cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 :: Cipher +cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 = Cipher { cipherID = 0x009E , cipherName = "TLS_DHE_RSA_WITH_AES_128_GCM_SHA256" @@ -404,8 +201,16 @@ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } -cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher -cipher_DHE_RSA_AES256GCM_SHA384 = +{-# DEPRECATED + cipher_DHE_RSA_AES128GCM_SHA256 + "Use cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 instead" + #-} +cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher +cipher_DHE_RSA_AES128GCM_SHA256 = cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 + +-- TLS_DHE_RSA_WITH_AES_256_GCM_SHA384 +cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 :: Cipher +cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 = Cipher { cipherID = 0x009F , cipherName = "TLS_DHE_RSA_WITH_AES_256_GCM_SHA384" @@ -416,11 +221,19 @@ , cipherMinVer = Just TLS12 } +{-# DEPRECATED + cipher_DHE_RSA_AES256GCM_SHA384 + "Use cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 instead" + #-} +cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher +cipher_DHE_RSA_AES256GCM_SHA384 = cipher_DHE_RSA_WITH_AES_256_GCM_SHA384 + ---------------------------------------------------------------- -- RFC 8446 -cipher_TLS13_AES128GCM_SHA256 :: Cipher -cipher_TLS13_AES128GCM_SHA256 = +-- TLS_AES_128_GCM_SHA256 +cipher13_AES_128_GCM_SHA256 :: Cipher +cipher13_AES_128_GCM_SHA256 = Cipher { cipherID = 0x1301 , cipherName = "TLS_AES_128_GCM_SHA256" @@ -431,8 +244,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES256GCM_SHA384 :: Cipher -cipher_TLS13_AES256GCM_SHA384 = +cipher_TLS13_AES128GCM_SHA256 :: Cipher +cipher_TLS13_AES128GCM_SHA256 = cipher13_AES_128_GCM_SHA256 +{-# DEPRECATED + cipher_TLS13_AES128GCM_SHA256 + "Use cipher13_AES_128_GCM_SHA256 instead" + #-} + +-- TLS_AES_256_GCM_SHA384 +cipher13_AES_256_GCM_SHA384 :: Cipher +cipher13_AES_256_GCM_SHA384 = Cipher { cipherID = 0x1302 , cipherName = "TLS_AES_256_GCM_SHA384" @@ -443,8 +264,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher -cipher_TLS13_CHACHA20POLY1305_SHA256 = +cipher_TLS13_AES256GCM_SHA384 :: Cipher +cipher_TLS13_AES256GCM_SHA384 = cipher13_AES_256_GCM_SHA384 +{-# DEPRECATED + cipher_TLS13_AES256GCM_SHA384 + "Use cipher13_AES_256_GCM_SHA384 instead" + #-} + +-- TLS_CHACHA20_POLY1305_SHA256 +cipher13_CHACHA20_POLY1305_SHA256 :: Cipher +cipher13_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0x1303 , cipherName = "TLS_CHACHA20_POLY1305_SHA256" @@ -455,8 +284,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES128CCM_SHA256 :: Cipher -cipher_TLS13_AES128CCM_SHA256 = +cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher +cipher_TLS13_CHACHA20POLY1305_SHA256 = cipher13_CHACHA20_POLY1305_SHA256 +{-# DEPRECATED + cipher_TLS13_CHACHA20POLY1305_SHA256 + "Use cipher13_CHACHA20_POLY1305_SHA256 instead" + #-} + +-- TLS_AES_128_CCM_SHA256 +cipher13_AES_128_CCM_SHA256 :: Cipher +cipher13_AES_128_CCM_SHA256 = Cipher { cipherID = 0x1304 , cipherName = "TLS_AES_128_CCM_SHA256" @@ -467,8 +304,16 @@ , cipherMinVer = Just TLS13 } -cipher_TLS13_AES128CCM8_SHA256 :: Cipher -cipher_TLS13_AES128CCM8_SHA256 = +cipher_TLS13_AES128CCM_SHA256 :: Cipher +cipher_TLS13_AES128CCM_SHA256 = cipher13_AES_128_CCM_SHA256 +{-# DEPRECATED + cipher_TLS13_AES128CCM_SHA256 + "Use cipher13_AES_128_CCM_SHA256 instead" + #-} + +-- TLS_AES_128_CCM_8_SHA256 +cipher13_AES_128_CCM_8_SHA256 :: Cipher +cipher13_AES_128_CCM_8_SHA256 = Cipher { cipherID = 0x1305 , cipherName = "TLS_AES_128_CCM_8_SHA256" @@ -479,11 +324,19 @@ , cipherMinVer = Just TLS13 } +cipher_TLS13_AES128CCM8_SHA256 :: Cipher +cipher_TLS13_AES128CCM8_SHA256 = cipher13_AES_128_CCM_8_SHA256 +{-# DEPRECATED + cipher_TLS13_AES128CCM8_SHA256 + "Use cipher13_AES_128_CCM_8_SHA256 instead" + #-} + ---------------------------------------------------------------- -- GCM: RFC 5289 -cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128GCM_SHA256 = +-- TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 +cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 = Cipher { cipherID = 0xC02B , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256" @@ -494,8 +347,16 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } -cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher -cipher_ECDHE_ECDSA_AES256GCM_SHA384 = +cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128GCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES128GCM_SHA256 + "Use cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 instead" + #-} + +-- TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 +cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 = Cipher { cipherID = 0xC02C , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384" @@ -506,8 +367,16 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } -cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher -cipher_ECDHE_RSA_AES128GCM_SHA256 = +cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher +cipher_ECDHE_ECDSA_AES256GCM_SHA384 = cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES256GCM_SHA384 + "Use cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 instead" + #-} + +-- TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 +cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 :: Cipher +cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 = Cipher { cipherID = 0xC02F , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256" @@ -518,8 +387,16 @@ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } -cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher -cipher_ECDHE_RSA_AES256GCM_SHA384 = +cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher +cipher_ECDHE_RSA_AES128GCM_SHA256 = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 +{-# DEPRECATED + cipher_ECDHE_RSA_AES128GCM_SHA256 + "Use cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 instead" + #-} + +-- TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 +cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 :: Cipher +cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 = Cipher { cipherID = 0xC030 , cipherName = "TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384" @@ -530,11 +407,19 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } +cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher +cipher_ECDHE_RSA_AES256GCM_SHA384 = cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 +{-# DEPRECATED + cipher_ECDHE_RSA_AES256GCM_SHA384 + "Use cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 instead" + #-} + ---------------------------------------------------------------- -- CCM/ECC: RFC 7251 -cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128CCM_SHA256 = +-- TLS_ECDHE_ECDSA_WITH_AES_128_CCM +cipher_ECDHE_ECDSA_WITH_AES_128_CCM :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_128_CCM = Cipher { cipherID = 0xC0AC , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM" @@ -545,8 +430,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES256CCM_SHA256 = +cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_CCM +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES128CCM_SHA256 + "User cipher_ECDHE_ECDSA_WITH_AES_128_CCM instead" + #-} + +-- TLS_ECDHE_ECDSA_WITH_AES_256_CCM +cipher_ECDHE_ECDSA_WITH_AES_256_CCM :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_256_CCM = Cipher { cipherID = 0xC0AD , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM" @@ -557,8 +450,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = +cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES256CCM_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_256_CCM +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES256CCM_SHA256 + "Use cipher_ECDHE_ECDSA_WITH_AES_256_CCM instead" + #-} + +-- TLS_ECDHE_ECDSA_WITH_AES_128_CCM_8 +cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 = Cipher { cipherID = 0xC0AE , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM_8" @@ -569,8 +470,16 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } -cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = +cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES128CCM8_SHA256 + "Use cipher_ECDHE_ECDSA_WITH_AES_128_CCM_8 instead" + #-} + +-- TLS_ECDHE_ECDSA_WITH_AES_256_CCM_8 +cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 :: Cipher +cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 = Cipher { cipherID = 0xC0AF , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM_8" @@ -581,11 +490,19 @@ , cipherMinVer = Just TLS12 -- RFC 7251 } +cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 +{-# DEPRECATED + cipher_ECDHE_ECDSA_AES256CCM8_SHA256 + "Use cipher_ECDHE_ECDSA_WITH_AES_256_CCM_8 instead" + #-} + ---------------------------------------------------------------- -- RFC 7905 -cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = +-- TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 +cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher +cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0xCCA8 , cipherName = "TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256" @@ -596,8 +513,16 @@ , cipherMinVer = Just TLS12 } -cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = +cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher +cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 +{-# DEPRECATED + cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 + "Use cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 instead" + #-} + +-- TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 +cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher +cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0xCCA9 , cipherName = "TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256" @@ -608,8 +533,16 @@ , cipherMinVer = Just TLS12 } -cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = +cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher +cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 +{-# DEPRECATED + cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 + "Use cipher_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 instead" + #-} + +-- TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 +cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 :: Cipher +cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 = Cipher { cipherID = 0xCCAA , cipherName = "TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256" @@ -619,3 +552,257 @@ , cipherKeyExchange = CipherKeyExchange_DHE_RSA , cipherMinVer = Just TLS12 } + +cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher +cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 +{-# DEPRECATED + cipher_DHE_RSA_CHACHA20POLY1305_SHA256 + "Use cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256 instead" + #-} + +---------------------------------------------------------------- +---------------------------------------------------------------- + +data CipherSet + = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm + | SetOther [Cipher] + +-- Preference between AEAD ciphers having equivalent properties is based on +-- hardware-acceleration support in the crypton implementation. +sortOptimized :: [CipherSet] -> [Cipher] +sortOptimized = concatMap f + where + f (SetAead gcm chacha ccm) + | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm + | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm + | otherwise = gcm ++ ccm ++ chacha + f (SetOther ciphers) = ciphers + +-- Order which is deterministic but not optimized for the CPU. +sortDeterministic :: [CipherSet] -> [Cipher] +sortDeterministic = concatMap f + where + f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm + f (SetOther ciphers) = ciphers + +---------------------------------------------------------------- + +aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD +aes128ccm BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) +aes128ccm BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in simpleDecrypt aeadIni ad d 16 + ) + +aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD +aes128ccm8 BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 8 + ) +aes128ccm8 BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in simpleDecrypt aeadIni ad d 8 + ) + +aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD +aes128gcm BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) +aes128gcm BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES128 + in ( \nonce d ad -> + let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) + in simpleDecrypt aeadIni ad d 16 + ) + +aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD +aes256ccm BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) +aes256ccm BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in simpleDecrypt aeadIni ad d 16 + ) + +aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD +aes256ccm8 BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 8 + ) +aes256ccm8 BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3 + aeadIni = noFail (aeadInit mode ctx nonce) + in simpleDecrypt aeadIni ad d 8 + ) + +aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD +aes256gcm BulkEncrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) +aes256gcm BulkDecrypt key = + let ctx = noFail (cipherInit key) :: AES256 + in ( \nonce d ad -> + let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) + in simpleDecrypt aeadIni ad d 16 + ) + +simpleDecrypt + :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag) +simpleDecrypt aeadIni header input taglen = (output, tag) + where + aead = aeadAppendHeader aeadIni header + (output, aeadFinal) = aeadDecrypt aead input + tag = aeadFinalize aeadFinal taglen + +noFail :: CryptoFailable a -> a +noFail = throwCryptoError + +chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD +chacha20poly1305 BulkEncrypt key nonce = + let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) + in ( \input ad -> + let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) + (output, st3) = ChaChaPoly1305.encrypt input st2 + Poly1305.Auth tag = ChaChaPoly1305.finalize st3 + in (output, AuthTag tag) + ) +chacha20poly1305 BulkDecrypt key nonce = + let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) + in ( \input ad -> + let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) + (output, st3) = ChaChaPoly1305.decrypt input st2 + Poly1305.Auth tag = ChaChaPoly1305.finalize st3 + in (output, AuthTag tag) + ) + +---------------------------------------------------------------- + +bulk_aes128ccm :: Bulk +bulk_aes128ccm = + Bulk + { bulkName = "AES128CCM" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128ccm + } + +bulk_aes128ccm8 :: Bulk +bulk_aes128ccm8 = + Bulk + { bulkName = "AES128CCM8" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 8 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128ccm8 + } + +bulk_aes128gcm :: Bulk +bulk_aes128gcm = + Bulk + { bulkName = "AES128GCM" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128gcm + } + +bulk_aes256ccm :: Bulk +bulk_aes256ccm = + Bulk + { bulkName = "AES256CCM" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256ccm + } + +bulk_aes256ccm8 :: Bulk +bulk_aes256ccm8 = + Bulk + { bulkName = "AES256CCM8" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 8 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256ccm8 + } + +bulk_aes256gcm :: Bulk +bulk_aes256gcm = + Bulk + { bulkName = "AES256GCM" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256gcm + } + +bulk_chacha20poly1305 :: Bulk +bulk_chacha20poly1305 = + Bulk + { bulkName = "CHACHA20POLY1305" + , bulkKeySize = 32 + , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length + , bulkExplicitIV = 0 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF chacha20poly1305 + } + +-- TLS13 bulks are same as TLS12 except they never have explicit IV +bulk_aes128gcm_13 :: Bulk +bulk_aes128gcm_13 = bulk_aes128gcm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes256gcm_13 :: Bulk +bulk_aes256gcm_13 = bulk_aes256gcm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes128ccm_13 :: Bulk +bulk_aes128ccm_13 = bulk_aes128ccm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes128ccm8_13 :: Bulk +bulk_aes128ccm8_13 = bulk_aes128ccm8{bulkIVSize = 12, bulkExplicitIV = 0} 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 @@ -86,7 +86,7 @@ hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer - let cipherIds = map cipherID ciphers + let cipherIds = map (CipherId . cipherID) ciphers compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts extensions0 <- catMaybes <$> getExtensions @@ -135,13 +135,10 @@ , preSharedKeyExtension -- MUST be last (RFC 8446) ] - toExtensionRaw :: Extension e => e -> ExtensionRaw - toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) - secureReneg = if supportedSecureRenegotiation $ ctxSupported ctx then do - cvd <- usingState_ ctx $ getVerifyData ClientRole + VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole return $ Just $ toExtensionRaw $ SecureRenegotiation cvd "" else return Nothing alpnExtension = do @@ -303,7 +300,7 @@ guard (sessionVersion sdata >= TLS13) let cid = sessionCipher sdata sids = map fst xs - sCipher <- find (\c -> cipherID c == cid) ciphers + sCipher <- findCipher cid ciphers Just (sid : sids, sdata, sCipher) getPskInfo = case sessions of diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs --- a/Network/TLS/Handshake/Client/Common.hs +++ b/Network/TLS/Handshake/Client/Common.hs @@ -334,16 +334,22 @@ ---------------------------------------------------------------- setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () -setALPN ctx msgt exts = case extensionLookup EID_ApplicationLayerProtocolNegotiation exts - >>= extensionDecode msgt of - Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do +setALPN ctx msgt exts = + lookupAndDecodeAndDo + EID_ApplicationLayerProtocolNegotiation + msgt + exts + (return ()) + setAlpn + where + setAlpn (ApplicationLayerProtocolNegotiation [proto]) = usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () - _ -> return () + setAlpn _ = return () ---------------------------------------------------------------- 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 @@ -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 cipher compression exts) = do +processServerHello cparams ctx (ServerHello rver serverRan serverSession (CipherId cid) compression exts) = do -- A server which receives a legacy_version value not equal to -- 0x0303 MUST abort the handshake with an "illegal_parameter" -- alert. @@ -76,7 +76,8 @@ -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx sentExts <- tls13stSentExtensions <$> getTLS13State ctx - cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of + let clientCiphers = supportedCiphers $ ctxSupported ctx + cipherAlg <- case findCipher cid clientCiphers of Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter Just alg -> return alg compressAlg <- case find @@ -99,11 +100,14 @@ let isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do setTLS13HRR isHRR - setTLS13Cookie - ( guard isHRR - >> extensionLookup EID_Cookie exts - >>= extensionDecode MsgTServerHello - ) + when (not isHRR) $ + setTLS13Cookie $ + lookupAndDecode + EID_Cookie + MsgTServerHello + exts + Nothing + (\cookie@(Cookie _) -> Just cookie) setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts @@ -163,8 +167,8 @@ processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw extID content) | extID == EID_SecureRenegotiation = do - cvd <- getVerifyData ClientRole - svd <- getVerifyData ServerRole + VerifyData cvd <- getVerifyData ClientRole + VerifyData svd <- getVerifyData ServerRole let bs = extensionEncode $ SecureRenegotiation cvd svd unless (bs == content) $ throwError $ 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 @@ -42,7 +42,7 @@ runRecvStateHS ctx st hs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) -expectCertificate cparams ctx (Certificate certs) = do +expectCertificate cparams ctx (Certificate (TLSCertificateChain certs)) = do usingState_ ctx $ setServerCertificateChain certs doCertificate cparams ctx certs processCertificate ctx ClientRole certs @@ -150,7 +150,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True - sendPacket12 ctx $ Handshake [Certificate cc] + sendPacket12 ctx $ Handshake [Certificate (TLSCertificateChain cc)] ---------------------------------------------------------------- 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 @@ -183,9 +183,7 @@ where -- setCertReqSigAlgsCert caAlgs - canames = case extensionLookup - EID_CertificateAuthorities - exts of + canames = case extensionLookup EID_CertificateAuthorities exts of Nothing -> return [] Just ext -> case extensionDecode MsgTCertificateRequest ext of Just (CertificateAuthorities names) -> return names @@ -205,7 +203,7 @@ -- not used in 0-RTT expectCertAndVerify :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () -expectCertAndVerify cparams ctx (Certificate13 _ cc _) = do +expectCertAndVerify cparams ctx (Certificate13 _ (TLSCertificateChain cc) _) = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc @@ -219,7 +217,7 @@ expectCertVerify :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m () -expectCertVerify ctx pubkey hChSc (CertVerify13 sigAlg sig) = do +expectCertVerify ctx pubkey hChSc (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify") @@ -333,7 +331,8 @@ let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx - loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] + loadPacket13 ctx $ + Handshake13 [Certificate13 token (TLSCertificateChain chain) certExts] case certs of [] -> return () _ -> do 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 @@ -21,7 +21,6 @@ onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret, - extensionLookup, getSessionData, storePrivInfo, isSupportedGroup, @@ -76,7 +75,9 @@ if tls13 then do when (established == EarlyDataSending) $ clearTxRecordState ctx - sendPacket13 ctx $ Alert13 [errorToAlert tlserror] + when (tlserror /= Error_TCP_Terminate) $ + sendPacket13 ctx $ + Alert13 [errorToAlert tlserror] else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where @@ -139,7 +140,9 @@ sendPacket12 ctx ChangeCipherSpec contextFlush ctx verifyData <- - usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role + VerifyData + <$> ( usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role + ) sendPacket12 ctx (Handshake [Finished verifyData]) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -209,14 +212,23 @@ | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False | otherwise = - case extensionLookup EID_ExtendedMainSecret exts >>= extensionDecode msgt of - Just ExtendedMainSecret -> usingHState ctx (setExtendedMainSecret True) >> return True - Nothing - | ems == RequireEMS -> throwCore $ Error_Protocol err HandshakeFailure - | otherwise -> return False + liftIO $ + lookupAndDecodeAndDo + EID_ExtendedMainSecret + msgt + exts + nonExistAction + existAction where - ems = supportedExtendedMainSecret (ctxSupported ctx) + ems = supportedExtendedMainSecret $ ctxSupported ctx err = "peer does not support Extended Main Secret" + nonExistAction = + if ems == RequireEMS + then throwCore $ Error_Protocol err HandshakeFailure + else return False + existAction ExtendedMainSecret = do + usingHState ctx $ setExtendedMainSecret True + return True getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do @@ -246,11 +258,6 @@ , sessionFlags = flags } -extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString -extensionLookup toFind = - fmap (\(ExtensionRaw _ content) -> content) - . find (\(ExtensionRaw eid _) -> eid == toFind) - -- | Store the specified keypair. Whether the public key and private key -- actually match is left for the peer to discover. We're not presently -- burning CPU to detect that misconfiguration. We verify only that the @@ -300,7 +307,8 @@ processFinished :: Context -> VerifyData -> IO () processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion - expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc + expected <- + VerifyData <$> (usingHState ctx $ getHandshakeDigest ver $ invertRole cc) when (expected /= verifyData) $ decryptError "cannot verify finished" usingState_ ctx $ setVerifyDataForRecv verifyData 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 @@ -76,19 +76,20 @@ makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 makeFinished ctx usedHash baseKey = do - verifyData <- makeVerifyData usedHash baseKey <$> transcriptHash ctx + verifyData <- + VerifyData . makeVerifyData usedHash baseKey <$> transcriptHash ctx liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData pure $ Finished13 verifyData checkFinished - :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m () -checkFinished ctx usedHash baseKey hashValue verifyData = do + :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> VerifyData -> m () +checkFinished ctx usedHash baseKey hashValue vd@(VerifyData verifyData) = do let verifyData' = makeVerifyData usedHash baseKey hashValue when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol "broken Finished" DecodeError unless (verifyData' == verifyData) $ decryptError "cannot verify finished" - liftIO $ usingState_ ctx $ setVerifyDataForRecv verifyData + liftIO $ usingState_ ctx $ setVerifyDataForRecv vd makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString makeVerifyData usedHash baseKey = hmac usedHash finishedKey @@ -152,7 +153,7 @@ | role == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue - CertVerify13 hs <$> sign ctx pub hs target + CertVerify13 <$> DigitallySigned hs <$> sign ctx pub hs target checkCertVerify :: MonadIO m @@ -204,11 +205,12 @@ -> Maybe ByteString -> IO ByteString makePSKBinder ctx (BaseSecret sec) usedHash truncLen mch = do - rmsgs0 <- usingHState ctx getHandshakeMessagesRev -- fixme - let rmsgs = case mch of - Just ch -> trunc ch : rmsgs0 - Nothing -> trunc (head rmsgs0) : tail rmsgs0 - hChTruncated = hash usedHash $ B.concat $ reverse rmsgs + rmsgs <- case mch of + Just ch -> (trunc ch :) <$> usingHState ctx getHandshakeMessagesRev + Nothing -> do + ch : rs <- usingHState ctx getHandshakeMessagesRev + return $ trunc ch : rs + let hChTruncated = hash usedHash $ B.concat $ reverse rmsgs binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "") return $ makeVerifyData usedHash binderKey hChTruncated where @@ -423,6 +425,7 @@ Right (Handshake13 []) -> error "invalid recvPacket13 result" Right (Handshake13 (h : hs)) -> found h hs Right ChangeCipherSpec13 -> recvLoop + Right (Alert13 _) -> throwCore Error_TCP_Terminate Right x -> unexpected (show x) (Just "handshake 13") Left err -> throwCore err diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -176,4 +176,4 @@ (label, key) = labelAndKey logkey ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key where - dump = init . tail . showBytesHex + dump = init . drop 1 . showBytesHex 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 @@ -25,7 +25,6 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 -import Network.TLS.Types -- Put the server context in handshake mode. -- @@ -69,7 +68,7 @@ recvClientSecondFlight13 sparams ctx r1 ch else do r <- - processClinetHello12 sparams ctx ch + processClientHello12 sparams ctx ch resumeSessionData <- sendServerHello12 sparams ctx r ch recvClientSecondFlight12 sparams ctx resumeSessionData diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs --- a/Network/TLS/Handshake/Server/ClientHello.hs +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -4,15 +4,16 @@ processClientHello, ) where +import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Extension -import Network.TLS.Handshake.Common import Network.TLS.Handshake.Process import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct +import Network.TLS.Types processClientHello :: ServerParams -> Context -> Handshake -> IO (Version, CH) @@ -51,16 +52,15 @@ -- TLS_FALLBACK_SCSV: {0x56, 0x00} when ( supportedFallbackScsv (ctxSupported ctx) - && (0x5600 `elem` chCiphers) + && (CipherId 0x5600 `elem` chCiphers) && legacyVersion < TLS12 ) $ throwCore $ Error_Protocol "fallback is not allowed" InappropriateFallback -- choosing TLS version - let clientVersions = case extensionLookup EID_SupportedVersions chExtensions - >>= extensionDecode MsgTClientHello of - Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == [] - _ -> [] + let extract (SupportedVersionsClientHello vers) = vers -- fixme: vers == [] + extract _ = [] + clientVersions = lookupAndDecode EID_SupportedVersions MsgTClientHello chExtensions [] extract clientVersion = min TLS12 legacyVersion serverVersions | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) @@ -86,15 +86,29 @@ Just v -> return v -- SNI (Server Name Indication) - let serverName = case extensionLookup EID_ServerName chExtensions >>= extensionDecode MsgTClientHello of - Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) - where - toHostName (ServerNameHostName hostName) = Just hostName - toHostName (ServerNameOther _) = Nothing - _ -> Nothing - when (chosenVersion == TLS13) $ do - -- If this is done for TLS12, SSL Labs test does not continue, sigh. - mapM_ ensureNullCompression compressions + let extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns) + toHostName (ServerNameHostName hostName) = Just hostName + toHostName (ServerNameOther _) = Nothing + serverName = + lookupAndDecode + EID_ServerName + MsgTClientHello + chExtensions + Nothing + extractServerName + let nullComp = compressionID nullCompression + case chosenVersion of + TLS13 -> + when (compressions /= [nullComp]) $ + throwCore $ + Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter + _ -> case find (== nullComp) compressions of + Nothing -> + throwCore $ + Error_Protocol + "compressions must include nullCompression in TLS 1.2" + IllegalParameter + _ -> return () maybe (return ()) (usingState_ ctx . setClientSNI) serverName return (chosenVersion, ch) processClientHello _ _ _ = 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 @@ -2,7 +2,7 @@ {-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Server.ClientHello12 ( - processClinetHello12, + processClientHello12, ) where import Network.TLS.Cipher @@ -11,50 +11,52 @@ import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension -import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct -import Network.TLS.Types (Role (..)) +import Network.TLS.Types (CipherId (..), Role (..)) ---------------------------------------------------------------- +-- serverSupported sparams == ctxSupported ctx + -- TLS 1.2 or earlier -processClinetHello12 +processClientHello12 :: ServerParams -> Context -> CH -> IO (Cipher, Maybe Credential) -processClinetHello12 sparams ctx ch = do - let secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx - when secureRenegotiation $ checkSesecureRenegotiation ctx ch +processClientHello12 sparams ctx ch = do + let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams + when secureRenegotiation $ checkSecureRenegotiation ctx ch serverName <- usingState_ ctx getClientSNI - extraCreds <- onServerNameIndication (serverHooks sparams) serverName + let hooks = serverHooks sparams + extraCreds <- onServerNameIndication hooks serverName let (creds, signatureCreds, ciphersFilteredVersion) = - credsTriple sparams ctx ch extraCreds + credsTriple sparams ch extraCreds -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists. when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure - let usedCipher = onCipherChoosing (serverHooks sparams) TLS12 ciphersFilteredVersion + let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds return (usedCipher, mcred) -checkSesecureRenegotiation :: Context -> CH -> IO () -checkSesecureRenegotiation ctx CH{..} = do +checkSecureRenegotiation :: Context -> CH -> IO () +checkSecureRenegotiation ctx CH{..} = do -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} - when (0xff `elem` chCiphers) $ + when (CipherId 0xff `elem` chCiphers) $ usingState_ ctx $ setSecureRenegotiation True case extensionLookup EID_SecureRenegotiation chExtensions of Just content -> usingState_ ctx $ do - cvd <- getVerifyData ClientRole + VerifyData cvd <- getVerifyData ClientRole let bs = extensionEncode (SecureRenegotiation cvd "") unless (bs == content) $ throwError $ @@ -69,19 +71,22 @@ credsTriple :: ServerParams - -> Context -> CH -> Credentials -> (Credentials, Credentials, [Cipher]) -credsTriple sparams ctx CH{..} extraCreds +credsTriple sparams CH{..} extraCreds | cipherListCredentialFallback cltCiphers = (allCreds, sigAllCreds, allCiphers) | otherwise = (cltCreds, sigCltCreds, cltCiphers) where - commonCiphers creds sigCreds = filter ((`elem` chCiphers) . cipherID) (getCiphers sparams creds sigCreds) + ciphers = supportedCiphers $ serverSupported sparams + commonCiphers creds sigCreds = intersectCiphers chCiphers availableCiphers + where + availableCiphers = getCiphers ciphers creds sigCreds + allCreds = filterCredentials (isCredentialAllowed TLS12 chExtensions) $ - extraCreds `mappend` sharedCredentials (ctxShared ctx) + extraCreds `mappend` sharedCredentials (serverShared sparams) -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements @@ -98,7 +103,9 @@ -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. - possibleGroups = negotiatedGroupsInCommon ctx chExtensions + supported = serverSupported sparams + groups = supportedGroups supported + possibleGroups = negotiatedGroupsInCommon groups chExtensions possibleECGroups = possibleGroups `intersect` availableECGroups possibleFFGroups = possibleGroups `intersect` availableFFGroups hasCommonGroupForECDHE = not (null possibleECGroups) @@ -121,7 +128,8 @@ -- Build a list of all hash/signature algorithms in common between -- client and server. - possibleHashSigAlgs = hashAndSignaturesInCommon ctx chExtensions + hashAndSignatures = supportedHashSignatures supported + possibleHashSigAlgs = hashAndSignaturesInCommon hashAndSignatures chExtensions -- Check that a candidate signature credential will be compatible with -- client & server hash/signature algorithms. This returns Just Int @@ -162,32 +170,14 @@ ---------------------------------------------------------------- -hashAndSignaturesInCommon - :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] -hashAndSignaturesInCommon ctx exts = - let cHashSigs = case extensionLookup EID_SignatureAlgorithms exts - >>= extensionDecode MsgTClientHello of - -- See Section 7.4.1.4.1 of RFC 5246. - Nothing -> - [ (HashSHA1, SignatureECDSA) - , (HashSHA1, SignatureRSA) - , (HashSHA1, SignatureDSA) - ] - Just (SignatureAlgorithms sas) -> sas - sHashSigs = supportedHashSignatures $ ctxSupported ctx - in -- The values in the "signature_algorithms" extension - -- are in descending order of preference. - -- However here the algorithms are selected according - -- to server preference in 'supportedHashSignatures'. - sHashSigs `intersect` cHashSigs - -negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] -negotiatedGroupsInCommon ctx exts = case extensionLookup EID_SupportedGroups exts - >>= extensionDecode MsgTClientHello of - Just (SupportedGroups clientGroups) -> - let serverGroups = supportedGroups (ctxSupported ctx) - in serverGroups `intersect` clientGroups - _ -> [] +negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] +negotiatedGroupsInCommon serverGroups exts = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + exts + [] + (\(SupportedGroups clientGroups) -> serverGroups `intersect` clientGroups) ---------------------------------------------------------------- @@ -217,8 +207,8 @@ -- subset of this list named 'sigCreds'. This list has been filtered in order -- to remove certificates that are not compatible with hash/signature -- restrictions (TLS 1.2). -getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher] -getCiphers sparams creds sigCreds = filter authorizedCKE (supportedCiphers $ serverSupported sparams) +getCiphers :: [Cipher] -> Credentials -> Credentials -> [Cipher] +getCiphers ciphers creds sigCreds = filter authorizedCKE ciphers where authorizedCKE cipher = case cipherKeyExchange cipher of 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 @@ -10,7 +10,6 @@ import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension -import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Random import Network.TLS.Handshake.State @@ -21,6 +20,7 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 +import Network.TLS.Types -- TLS 1.3 or later processClientHello13 @@ -42,30 +42,31 @@ Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure let usedCipher = onCipherChoosing (serverHooks sparams) TLS13 ciphersFilteredVersion usedHash = cipherHash usedCipher - rtt0 = case extensionLookup EID_EarlyData chExtensions >>= extensionDecode MsgTClientHello of - Just (EarlyDataIndication _) -> True - Nothing -> False + rtt0 = + lookupAndDecode + EID_EarlyData + MsgTClientHello + 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 - keyShares <- case extensionLookup EID_KeyShare chExtensions of - Nothing -> + let require = throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" MissingExtension - Just kss -> case extensionDecode MsgTClientHello kss of - Just (KeyShareClientHello kses) -> return kses - Just _ -> - error "processClientHello13: invalid KeyShare value" - _ -> - throwCore $ Error_Protocol "broken key_share" DecodeError + extract (KeyShareClientHello kses) = return kses + extract _ = require + keyShares <- + lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract mshare <- findKeyShare keyShares serverGroups return (mshare, (usedCipher, usedHash, rtt0)) where - ciphersFilteredVersion = filter ((`elem` chCiphers) . cipherID) serverCiphers + ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) @@ -94,10 +95,13 @@ Error_Protocol "Hello retry not allowed again" HandshakeFailure usingState_ ctx $ setTLS13HRR True failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher - let clientGroups = case extensionLookup EID_SupportedGroups chExtensions - >>= extensionDecode MsgTClientHello of - Just (SupportedGroups gs) -> gs - Nothing -> [] + let clientGroups = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + chExtensions + [] + (\(SupportedGroups gs) -> gs) possibleGroups = serverGroups `intersect` clientGroups case possibleGroups of [] -> @@ -110,7 +114,7 @@ [ ExtensionRaw EID_KeyShare serverKeyShare , ExtensionRaw EID_SupportedVersions selectedVersion ] - hrr = ServerHello13 hrrRandom chSession (cipherID usedCipher) extensions + hrr = ServerHello13 hrrRandom chSession (CipherId $ cipherID usedCipher) extensions usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest runPacketFlight ctx $ do loadPacket13 ctx $ Handshake13 [hrr] 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 @@ -9,6 +9,7 @@ filterCredentialsWithHashSignatures, isCredentialAllowed, storePrivInfoServer, + hashAndSignaturesInCommon, ) where import Control.Monad.State.Strict @@ -59,10 +60,13 @@ -- not after. With TLS13, the curve is linked to the signature algorithm -- and client support is tested with signatureCompatible13. p - | ver < TLS13 = case extensionLookup EID_SupportedGroups exts - >>= extensionDecode MsgTClientHello of - Nothing -> const True - Just (SupportedGroups sg) -> (`elem` sg) + | ver < TLS13 = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + exts + (const True) + (\(SupportedGroups sg) -> (`elem` sg)) | otherwise = const True -- Filters a list of candidate credentials with credentialMatchesHashSignatures. @@ -86,42 +90,52 @@ filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials filterCredentialsWithHashSignatures exts = - case withExt EID_SignatureAlgorithmsCert of - Just (SignatureAlgorithmsCert sas) -> withAlgs sas - Nothing -> - case withExt EID_SignatureAlgorithms of - Nothing -> id - Just (SignatureAlgorithms sas) -> withAlgs sas + lookupAndDecode + EID_SignatureAlgorithmsCert + MsgTClientHello + exts + lookupSignatureAlgorithms + (\(SignatureAlgorithmsCert sas) -> withAlgs sas) where - withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello + lookupSignatureAlgorithms = + lookupAndDecode + EID_SignatureAlgorithms + MsgTClientHello + exts + id + (\(SignatureAlgorithms sas) -> withAlgs sas) withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) storePrivInfoServer :: MonadIO m => Context -> Credential -> m () storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) +-- ALPN (Application Layer Protocol Negotiation) applicationProtocol - :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] -applicationProtocol ctx exts sparams = do - -- ALPN (Application Layer Protocol Negotiation) - case extensionLookup EID_ApplicationLayerProtocolNegotiation exts - >>= extensionDecode MsgTClientHello of - Nothing -> return [] - Just (ApplicationLayerProtocolNegotiation protos) -> do - case onALPNClientSuggest $ serverHooks sparams of - Just io -> do - proto <- io protos - when (proto == "") $ - throwCore $ - Error_Protocol "no supported application protocols" NoApplicationProtocol - usingState_ ctx $ do - setExtensionALPN True - setNegotiatedProtocol proto - return - [ ExtensionRaw - EID_ApplicationLayerProtocolNegotiation - (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) - ] - _ -> return [] + :: Context -> [ExtensionRaw] -> ServerParams -> IO (Maybe ExtensionRaw) +applicationProtocol ctx exts sparams = case onALPN of + Nothing -> return Nothing + Just io -> + lookupAndDecodeAndDo + EID_ApplicationLayerProtocolNegotiation + MsgTClientHello + exts + (return Nothing) + $ select io + where + onALPN = onALPNClientSuggest $ serverHooks sparams + select io (ApplicationLayerProtocolNegotiation protos) = do + proto <- io protos + when (proto == "") $ + throwCore $ + Error_Protocol "no supported application protocols" NoApplicationProtocol + usingState_ ctx $ do + setExtensionALPN True + setNegotiatedProtocol proto + return $ + Just $ + ExtensionRaw + EID_ApplicationLayerProtocolNegotiation + (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do @@ -142,3 +156,27 @@ -- Remember cert chain for later use. -- usingHState ctx $ setClientCertChain certs + +---------------------------------------------------------------- + +-- The values in the "signature_algorithms" extension +-- are in descending order of preference. +-- However here the algorithms are selected according +-- to server preference in 'supportedHashSignatures'. +hashAndSignaturesInCommon + :: [HashAndSignatureAlgorithm] -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] +hashAndSignaturesInCommon sHashSigs exts = sHashSigs `intersect` cHashSigs + where + -- See Section 7.4.1.4.1 of RFC 5246. + defVal = + [ (HashSHA1, SignatureECDSA) + , (HashSHA1, SignatureRSA) + , (HashSHA1, SignatureDSA) + ] + cHashSigs = + lookupAndDecode + EID_SignatureAlgorithms + MsgTClientHello + exts + defVal + (\(SignatureAlgorithms sas) -> sas) 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 @@ -62,34 +62,40 @@ recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions - let mSessionTicket = - extensionLookup EID_SessionTicket chExtensions - >>= extensionDecode MsgTClientHello - mticket = case mSessionTicket of - Nothing -> Nothing - Just (SessionTicket ticket) -> Just ticket + let mticket = + lookupAndDecode + EID_SessionTicket + MsgTClientHello + chExtensions + Nothing + (\(SessionTicket ticket) -> Just ticket) midentity = ticketOrSessionID12 mticket chSession case midentity of Nothing -> return Nothing Just identity -> do sd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity - validateSession chCiphers serverName ems sd + validateSession ctx chCiphers serverName ems sd validateSession - :: [CipherID] + :: Context + -> [CipherId] -> Maybe HostName -> Bool -> Maybe SessionData -> IO (Maybe SessionData) -validateSession _ _ _ Nothing = return Nothing -validateSession ciphers sni ems m@(Just sd) +validateSession _ _ _ _ Nothing = return Nothing +validateSession ctx ciphers sni ems m@(Just sd) -- SessionData parameters are assumed to match the local server configuration -- so we need to compare only to ClientHello inputs. Abbreviated handshake -- uses the same server_name than full handshake so the same -- credentials (and thus ciphers) are available. | TLS12 < sessionVersion sd = return Nothing -- fixme - | sessionCipher sd `notElem` ciphers = return Nothing - | isJust sni && sessionClientSNI sd /= sni = return Nothing + | CipherId (sessionCipher sd) `notElem` ciphers = + throwCore $ + Error_Protocol "new cipher is diffrent from the old one" IllegalParameter + | isJust sni && sessionClientSNI sd /= sni = do + usingState_ ctx clearClientSNI + return Nothing | ems && not emsSession = return Nothing | not ems && emsSession = let err = "client resumes an EMS session without EMS" @@ -110,7 +116,7 @@ let cc = case mcred of Just (srvCerts, _) -> srvCerts _ -> CertificateChain [] - let b1 = b0 . (Certificate cc :) + let b1 = b0 . (Certificate (TLSCertificateChain cc) :) usingState_ ctx $ setServerCertificateChain cc -- send server key exchange if needed @@ -176,7 +182,7 @@ -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do - let hashSigs = hashAndSignaturesInCommon ctx chExts + let hashSigs = hashAndSignaturesInCommon (supportedHashSignatures $ ctxSupported ctx) chExts case filter (pubKey `signatureCompatible`) hashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x : _ -> return x @@ -245,21 +251,19 @@ if secReneg then do vd <- usingState_ ctx $ do - cvd <- getVerifyData ClientRole - svd <- getVerifyData ServerRole - return $ extensionEncode $ SecureRenegotiation cvd svd - return [ExtensionRaw EID_SecureRenegotiation vd] - else return [] + 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 = - let raw = extensionEncode ExtendedMainSecret - in [ExtensionRaw EID_ExtendedMainSecret raw] - | otherwise = [] + | ems = Just $ toExtensionRaw ExtendedMainSecret + | otherwise = Nothing protoExt <- applicationProtocol ctx chExts sparams sniExt <- do if resuming - then return [] + then return Nothing else do msni <- usingState_ ctx getClientSNI case msni of @@ -267,21 +271,25 @@ -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. - Just _ -> return [ExtensionRaw EID_ServerName ""] - Nothing -> return [] + Just _ -> return $ Just $ toExtensionRaw $ ServerName [] + Nothing -> return Nothing let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams ticktExt - | not resuming && useTicket = - let raw = extensionEncode $ SessionTicket "" - in [ExtensionRaw EID_SessionTicket raw] - | otherwise = [] + | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket "" + | otherwise = Nothing + let eccExt = case extensionLookup EID_EcPointFormats chExts of + Nothing -> Nothing + Just _ -> Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] let shExts = sharedHelloExtensions (serverShared sparams) - ++ secRengExt - ++ emsExt - ++ protoExt - ++ sniExt - ++ ticktExt + ++ catMaybes + [ secRengExt + , emsExt + , protoExt + , sniExt + , ticktExt + , eccExt + ] usingState_ ctx $ setVersion TLS12 usingHState ctx $ setServerHelloParameters TLS12 srand usedCipher nullCompression @@ -290,33 +298,18 @@ TLS12 srand session - (cipherID usedCipher) + (CipherId (cipherID usedCipher)) (compressionID nullCompression) shExts -hashAndSignaturesInCommon - :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] -hashAndSignaturesInCommon ctx chExts = - let cHashSigs = case extensionLookup EID_SignatureAlgorithms chExts - >>= extensionDecode MsgTClientHello of - -- See Section 7.4.1.4.1 of RFC 5246. - Nothing -> - [ (HashSHA1, SignatureECDSA) - , (HashSHA1, SignatureRSA) - , (HashSHA1, SignatureDSA) - ] - Just (SignatureAlgorithms sas) -> sas - sHashSigs = supportedHashSignatures $ ctxSupported ctx - in -- The values in the "signature_algorithms" extension - -- are in descending order of preference. - -- However here the algorithms are selected according - -- to server preference in 'supportedHashSignatures'. - sHashSigs `intersect` cHashSigs - negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] -negotiatedGroupsInCommon ctx chExts = case extensionLookup EID_SupportedGroups chExts - >>= extensionDecode MsgTClientHello of - Just (SupportedGroups clientGroups) -> - let serverGroups = supportedGroups (ctxSupported ctx) - in serverGroups `intersect` clientGroups - _ -> [] +negotiatedGroupsInCommon ctx chExts = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + chExts + [] + 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 @@ -134,49 +134,59 @@ failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher return srand - supportsPHA = case extensionLookup EID_PostHandshakeAuth chExtensions - >>= extensionDecode MsgTClientHello of - Just PostHandshakeAuth -> True - Nothing -> False + supportsPHA = + lookupAndDecode + EID_PostHandshakeAuth + MsgTClientHello + chExtensions + False + (\PostHandshakeAuth -> True) - choosePSK = case extensionLookup EID_PreSharedKey chExtensions - >>= extensionDecode MsgTClientHello of - Just (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) -> do - when (null dhModes) $ - throwCore $ - Error_Protocol "no psk_key_exchange_modes extension" MissingExtension - if PSK_DHE_KE `elem` dhModes - then do - let len = sum (map (\x -> B.length x + 1) bnds) + 2 - mgr = sharedSessionManager $ serverShared sparams - -- sessionInvalidate is not used for TLS 1.3 - -- because PSK is always changed. - -- So, identity is not stored in Context. - msdata <- - if rtt0 - then sessionResumeOnlyOnce mgr identity - else sessionResume mgr identity - case msdata of - Just sdata -> do - let tinfo = fromJust $ sessionTicketInfo sdata - psk = sessionSecret sdata - isFresh <- checkFreshness tinfo obfAge - (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata - if isPSKvalid && isFresh - then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid) - else -- fall back to full handshake - return (zero, Nothing, False) - _ -> return (zero, Nothing, False) - else return (zero, Nothing, False) - _ -> return (zero, Nothing, False) + selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do + when (null dhModes) $ + throwCore $ + Error_Protocol "no psk_key_exchange_modes extension" MissingExtension + if PSK_DHE_KE `elem` dhModes + then do + let len = sum (map (\x -> B.length x + 1) bnds) + 2 + mgr = sharedSessionManager $ serverShared sparams + -- sessionInvalidate is not used for TLS 1.3 + -- because PSK is always changed. + -- So, identity is not stored in Context. + msdata <- + if rtt0 + then sessionResumeOnlyOnce mgr identity + else sessionResume mgr identity + case msdata of + Just sdata -> do + let tinfo = fromJust $ sessionTicketInfo sdata + psk = sessionSecret sdata + isFresh <- checkFreshness tinfo obfAge + (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata + if isPSKvalid && isFresh + then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid) + else -- fall back to full handshake + return (zero, Nothing, False) + _ -> return (zero, Nothing, False) + else return (zero, Nothing, False) + selectPSK _ = return (zero, Nothing, False) + choosePSK = + lookupAndDecodeAndDo + EID_PreSharedKey + MsgTClientHello + chExtensions + (return (zero, Nothing, False)) + selectPSK + checkSessionEquality sdata = do msni <- usingState_ ctx getClientSNI malpn <- usingState_ ctx getNegotiatedProtocol let isSameSNI = sessionClientSNI sdata == msni isSameCipher = sessionCipher sdata == cipherID usedCipher ciphers = supportedCiphers $ serverSupported sparams - isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of + scid = sessionCipher sdata + isSameKDF = case findCipher scid ciphers of Nothing -> False Just c -> cipherHash c == cipherHash usedCipher isSameVersion = TLS13 == sessionVersion sdata @@ -193,17 +203,18 @@ binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing unless (binder == binder') $ decryptError "PSK binder validation failed" - let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n - return [ExtensionRaw EID_PreSharedKey selectedIdentity] + return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n] decideCredentialInfo allCreds = do - cHashSigs <- case extensionLookup EID_SignatureAlgorithms chExtensions of - Nothing -> - throwCore $ Error_Protocol "no signature_algorithms extension" MissingExtension - Just sa -> case extensionDecode MsgTClientHello sa of - Nothing -> - throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError - Just (SignatureAlgorithms sas) -> return sas + let err = + throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError + cHashSigs <- + lookupAndDecodeAndDo + EID_SignatureAlgorithms + MsgTClientHello + chExtensions + err + (\(SignatureAlgorithms sas) -> return sas) -- When deciding signature algorithm and certificate, we try to keep -- certificates supported by the client, but fallback to all credentials -- if this produces no suitable result (see RFC 5246 section 7.4.2 and @@ -219,13 +230,11 @@ mcs -> return mcs sendServerHello keyShare srand extensions = do - let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare - selectedVersion = extensionEncode $ SupportedVersionsServerHello TLS13 - extensions' = - ExtensionRaw EID_KeyShare serverKeyShare - : ExtensionRaw EID_SupportedVersions selectedVersion + let extensions' = + toExtensionRaw (KeyShareServerHello keyShare) + : toExtensionRaw (SupportedVersionsServerHello TLS13) : extensions - helo = ServerHello13 srand chSession (cipherID usedCipher) extensions' + helo = ServerHello13 srand chSession (CipherId (cipherID usedCipher)) extensions' loadPacket13 ctx $ Handshake13 [helo] sendCertAndVerify cred@(certChain, _) hashSig = do @@ -238,7 +247,8 @@ let CertificateChain cs = certChain ess = replicate (length cs) [] - loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] + loadPacket13 ctx $ + Handshake13 [Certificate13 "" (TLSCertificateChain certChain) ess] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx pubkey <- getLocalPublicKey ctx @@ -252,22 +262,19 @@ -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty. - Just _ -> Just $ ExtensionRaw EID_ServerName "" + Just _ -> Just $ toExtensionRaw $ ServerName [] Nothing -> Nothing mgroup <- usingHState ctx getSupportedGroup let serverGroups = supportedGroups (ctxSupported ctx) - groupExtension - | null serverGroups = Nothing - | maybe True (== head serverGroups) mgroup = Nothing - | otherwise = - Just $ - ExtensionRaw EID_SupportedGroups $ - extensionEncode (SupportedGroups serverGroups) + groupExtension = case serverGroups of + [] -> Nothing + rg : _ -> case mgroup of + Nothing -> Nothing + Just grp + | grp == rg -> Nothing + | otherwise -> Just $ toExtensionRaw $ SupportedGroups serverGroups let earlyDataExtension - | rtt0OK = - Just $ - ExtensionRaw EID_EarlyData $ - extensionEncode (EarlyDataIndication Nothing) + | rtt0OK = Just $ toExtensionRaw $ EarlyDataIndication Nothing | otherwise = Nothing let extensions = sharedHelloExtensions (serverShared sparams) @@ -275,16 +282,19 @@ [ earlyDataExtension , groupExtension , sniExtension + , protoExt ] - ++ protoExt extensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions'] - dhModes = case extensionLookup EID_PskKeyExchangeModes chExtensions - >>= extensionDecode MsgTClientHello of - Just (PskKeyExchangeModes ms) -> ms - Nothing -> [] + dhModes = + lookupAndDecode + EID_PskKeyExchangeModes + MsgTClientHello + chExtensions + [] + (\(PskKeyExchangeModes ms) -> ms) hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 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 @@ -83,7 +83,7 @@ recvClientCCC :: ServerParams -> Context -> IO () recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate) where - expectClientCertificate (Certificate certs) = do + expectClientCertificate (Certificate (TLSCertificateChain certs)) = do clientCertificate sparams ctx certs processCertificate ctx ServerRole certs @@ -135,15 +135,17 @@ (rver, role, random) <- usingState_ ctx $ do (,,) <$> getVersion <*> getRole <*> genRandom 48 ePreMain <- decryptRSA ctx encryptedPreMain - mainSecret <- usingHState ctx $ do - expectedVer <- gets hstClientVersion - case ePreMain of - Left _ -> setMainSecretFromPre rver role random - Right preMain -> case decodePreMainSecret preMain of - Left _ -> setMainSecretFromPre rver role random - Right (ver, _) - | ver /= expectedVer -> setMainSecretFromPre rver role random - | otherwise -> setMainSecretFromPre rver role preMain + expectedVer <- usingHState ctx $ gets hstClientVersion + mainSecret <- case ePreMain of + Left _ -> + -- BadRecordMac is nonsense but for tlsfuzzer + throwCore $ + Error_Protocol "invalid client public key" BadRecordMac + Right preMain -> case decodePreMainSecret preMain of + Left _ -> usingHState ctx $ setMainSecretFromPre rver role random + Right (ver, _) + | ver /= expectedVer -> usingHState ctx $ setMainSecretFromPre rver role random + | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion 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 @@ -95,7 +95,7 @@ expectCertificate :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool -expectCertificate sparams ctx (Certificate13 certCtx certs _ext) = liftIO $ do +expectCertificate sparams ctx (Certificate13 certCtx (TLSCertificateChain certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter @@ -153,7 +153,7 @@ expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () -expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do +expectCertVerify sparams ctx hChCc (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected" pubkey <- case cc of @@ -192,7 +192,7 @@ else decryptError "verification failed" postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () -postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do +postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx (TLSCertificateChain certs) _ext) = do mCertReq <- getCertRequest13 ctx certCtx when (isNothing mCertReq) $ throwCore $ diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/HashAndSignature.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Network.TLS.HashAndSignature ( + HashAlgorithm ( + .., + HashNone, + HashMD5, + HashSHA1, + HashSHA224, + HashSHA256, + HashSHA384, + HashSHA512, + HashIntrinsic + ), + SignatureAlgorithm ( + .., + SignatureAnonymous, + SignatureRSA, + SignatureDSA, + SignatureECDSA, + SignatureRSApssRSAeSHA256, + SignatureRSApssRSAeSHA384, + SignatureRSApssRSAeSHA512, + SignatureEd25519, + SignatureEd448, + SignatureRSApsspssSHA256, + SignatureRSApsspssSHA384, + SignatureRSApsspssSHA512 + ), + HashAndSignatureAlgorithm, + supportedSignatureSchemes, +) where + +import Network.TLS.Imports + +------------------------------------------------------------ + +newtype HashAlgorithm = HashAlgorithm {fromHashAlgorithm :: Word8} + deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern HashNone :: HashAlgorithm +pattern HashNone = HashAlgorithm 0 +pattern HashMD5 :: HashAlgorithm +pattern HashMD5 = HashAlgorithm 1 +pattern HashSHA1 :: HashAlgorithm +pattern HashSHA1 = HashAlgorithm 2 +pattern HashSHA224 :: HashAlgorithm +pattern HashSHA224 = HashAlgorithm 3 +pattern HashSHA256 :: HashAlgorithm +pattern HashSHA256 = HashAlgorithm 4 +pattern HashSHA384 :: HashAlgorithm +pattern HashSHA384 = HashAlgorithm 5 +pattern HashSHA512 :: HashAlgorithm +pattern HashSHA512 = HashAlgorithm 6 +pattern HashIntrinsic :: HashAlgorithm +pattern HashIntrinsic = HashAlgorithm 8 + +instance Show HashAlgorithm where + show HashNone = "None" + show HashMD5 = "MD5" + show HashSHA1 = "SHA1" + show HashSHA224 = "SHA224" + show HashSHA256 = "SHA256" + show HashSHA384 = "SHA384" + show HashSHA512 = "SHA512" + show HashIntrinsic = "TLS13" + show (HashAlgorithm x) = "Hash " ++ show x +{- FOURMOLU_ENABLE -} + +------------------------------------------------------------ + +newtype SignatureAlgorithm = SignatureAlgorithm {fromSignatureAlgorithm :: Word8} + deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern SignatureAnonymous :: SignatureAlgorithm +pattern SignatureAnonymous = SignatureAlgorithm 0 +pattern SignatureRSA :: SignatureAlgorithm +pattern SignatureRSA = SignatureAlgorithm 1 +pattern SignatureDSA :: SignatureAlgorithm +pattern SignatureDSA = SignatureAlgorithm 2 +pattern SignatureECDSA :: SignatureAlgorithm +pattern SignatureECDSA = SignatureAlgorithm 3 +-- TLS 1.3 from here +pattern SignatureRSApssRSAeSHA256 :: SignatureAlgorithm +pattern SignatureRSApssRSAeSHA256 = SignatureAlgorithm 4 +pattern SignatureRSApssRSAeSHA384 :: SignatureAlgorithm +pattern SignatureRSApssRSAeSHA384 = SignatureAlgorithm 5 +pattern SignatureRSApssRSAeSHA512 :: SignatureAlgorithm +pattern SignatureRSApssRSAeSHA512 = SignatureAlgorithm 6 +pattern SignatureEd25519 :: SignatureAlgorithm +pattern SignatureEd25519 = SignatureAlgorithm 7 +pattern SignatureEd448 :: SignatureAlgorithm +pattern SignatureEd448 = SignatureAlgorithm 8 +pattern SignatureRSApsspssSHA256 :: SignatureAlgorithm +pattern SignatureRSApsspssSHA256 = SignatureAlgorithm 9 +pattern SignatureRSApsspssSHA384 :: SignatureAlgorithm +pattern SignatureRSApsspssSHA384 = SignatureAlgorithm 10 +pattern SignatureRSApsspssSHA512 :: SignatureAlgorithm +pattern SignatureRSApsspssSHA512 = SignatureAlgorithm 11 + +instance Show SignatureAlgorithm where + show SignatureAnonymous = "Anonymous" + show SignatureRSA = "RSA" + show SignatureDSA = "DSA" + show SignatureECDSA = "ECDSA" + show SignatureRSApssRSAeSHA256 = "RSApssRSAeSHA256" + show SignatureRSApssRSAeSHA384 = "RSApssRSAeSHA384" + show SignatureRSApssRSAeSHA512 = "RSApssRSAeSHA512" + show SignatureEd25519 = "Ed25519" + show SignatureEd448 = "Ed448" + show SignatureRSApsspssSHA256 = "RSApsspssSHA256" + show SignatureRSApsspssSHA384 = "RSApsspssSHA384" + show SignatureRSApsspssSHA512 = "RSApsspssSHA512" + show (SignatureAlgorithm x) = "Signature " ++ show x +{- FOURMOLU_ENABLE -} + +------------------------------------------------------------ + +type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) + +{- FOURMOLU_DISABLE -} +supportedSignatureSchemes :: [HashAndSignatureAlgorithm] +supportedSignatureSchemes = + -- EdDSA algorithms + [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) + , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) + -- ECDSA algorithms + , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403) + , (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) + -- RSASSA-PKCS1-v1_5 algorithms + , (HashSHA512, SignatureRSA) -- rsa_pkcs1_sha512(0x0601) + , (HashSHA384, SignatureRSA) -- rsa_pkcs1_sha384(0x0501) + , (HashSHA256, SignatureRSA) -- rsa_pkcs1_sha256(0x0401) + -- Legacy algorithms + , (HashSHA1, SignatureRSA) -- rsa_pkcs1_sha1 (0x0201) + , (HashSHA1, SignatureECDSA) -- ecdsa_sha1 (0x0203) + ] +{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -1,19 +1,25 @@ {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Internal ( - module Network.TLS.Struct, - module Network.TLS.Struct13, + module Network.TLS.Extension, 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, sendPacket12, recvPacket12, + makeCipherShowPretty, ) where +import Data.IORef + import Network.TLS.Core (recvPacket12, sendPacket12) +import Network.TLS.Extension +import Network.TLS.Extra.Cipher import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Receiving @@ -22,3 +28,8 @@ import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire + +---------------------------------------------------------------- + +makeCipherShowPretty :: IO () +makeCipherShowPretty = writeIORef globalCipherDict ciphersuite_all diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -66,11 +66,12 @@ decodeCertificateChain, encodeCertificateChain, ) -import Network.TLS.Cipher (Cipher (..), CipherKeyExchangeType (..)) + import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.MAC import Network.TLS.Struct +import Network.TLS.Types import Network.TLS.Util.ASN1 import Network.TLS.Wire @@ -140,21 +141,23 @@ content <- getOpaque24 return (ty, content) +{- FOURMOLU_DISABLE -} decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of - HandshakeType_HelloRequest -> decodeHelloRequest - HandshakeType_ClientHello -> decodeClientHello - HandshakeType_ServerHello -> decodeServerHello - HandshakeType_Certificate -> decodeCertificate - HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp - HandshakeType_CertRequest -> decodeCertRequest cp - HandshakeType_ServerHelloDone -> decodeServerHelloDone - HandshakeType_CertVerify -> decodeCertVerify cp - HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp - HandshakeType_Finished -> decodeFinished + HandshakeType_HelloRequest -> decodeHelloRequest + HandshakeType_ClientHello -> decodeClientHello + HandshakeType_ServerHello -> decodeServerHello + HandshakeType_Certificate -> decodeCertificate + HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp + HandshakeType_CertRequest -> decodeCertRequest cp + HandshakeType_ServerHelloDone -> decodeServerHelloDone + HandshakeType_CertVerify -> decodeCertVerify cp + HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp + HandshakeType_Finished -> decodeFinished HandshakeType_NewSessionTicket -> decodeNewSessionTicket x -> fail $ "Unsupported HandshakeType " ++ show x +{- FOURMOLU_ENABLE -} decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest @@ -164,16 +167,15 @@ ver <- getBinaryVersion random <- getClientRandom32 session <- getSession - ciphers <- getWords16 + ciphers <- map CipherId <$> getWords16 compressions <- getWords8 r <- remaining exts <- if r > 0 then fromIntegral <$> getWord16 >>= getExtensions - else do - rest <- remaining - _ <- getBytes rest - return [] + else return [] + r1 <- remaining + when (r1 /= 0) $ fail "Client hello" let ch = CH session ciphers exts return $ ClientHello ver random compressions ch @@ -182,7 +184,7 @@ ver <- getBinaryVersion random <- getServerRandom32 session <- getSession - cipherid <- getWord16 + cipherid <- CipherId <$> getWord16 compressionid <- getWord8 r <- remaining exts <- @@ -201,12 +203,12 @@ <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) - Right cc -> return $ Certificate cc + Right cc -> return $ Certificate $ TLSCertificateChain cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake -decodeFinished = Finished <$> (remaining >>= getBytes) +decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes) decodeNewSessionTicket :: Get Handshake decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16 @@ -242,7 +244,7 @@ decodeClientKeyXchg cp = -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of - Nothing -> error "no client key exchange type" + Nothing -> fail "no client key exchange type" Just cke -> ClientKeyXchg <$> parseCKE cke where parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes) @@ -251,7 +253,7 @@ parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic - parseCKE _ = error "unsupported client key exchange type" + parseCKE _ = fail "unsupported client key exchange type" parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16 parseClientECDHPublic = CKX_ECDH <$> getOpaque8 @@ -317,7 +319,7 @@ putBinaryVersion version putClientRandom32 random putSession chSession - putWords16 chCiphers + putWords16 $ map fromCipherId chCiphers putWords8 compressionIDs putExtensions chExtensions return () @@ -325,11 +327,11 @@ putBinaryVersion version putServerRandom32 random putSession session - putWord16 cipherid + putWord16 $ fromCipherId cipherid putWord8 compressionID putExtensions exts return () -encodeHandshake' (Certificate cc) = encodeCertificate cc +encodeHandshake' (Certificate (TLSCertificateChain cc)) = encodeCertificate cc encodeHandshake' (ClientKeyXchg ckx) = runPut $ do case ckx of CKX_RSA encryptedPreMain -> putBytes encryptedPreMain @@ -344,8 +346,7 @@ SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes - _ -> - error ("encodeHandshake': cannot handle: " ++ show skg) + _ -> error ("encodeHandshake': cannot handle: " ++ show skg) encodeHandshake' HelloRequest = "" encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do @@ -357,7 +358,7 @@ sigAlgs putDNames certAuthorities encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned -encodeHandshake' (Finished opaque) = runPut $ putBytes opaque +encodeHandshake' (Finished (VerifyData opaque)) = runPut $ putBytes opaque encodeHandshake' (NewSessionTicket life ticket) = runPut $ do putWord32 life putOpaque16 ticket @@ -399,7 +400,9 @@ len8 <- getWord8 case fromIntegral len8 of 0 -> return $ Session Nothing - len -> Session . Just <$> getBytes len + len + | len > 32 -> fail "the length of session id must be <= 32" + | otherwise -> Session . Just <$> getBytes len putSession :: Session -> Put putSession (Session Nothing) = putWord8 0 @@ -447,10 +450,9 @@ grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint case decodeGroupPublic grp mxy of - Left e -> error $ "getServerECDHParams: " ++ show e + Left e -> fail $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub - _ -> - error "getServerECDHParams: unknown type for ECDH Params" + _ -> fail "getServerECDHParams: unknown type for ECDH Params" -- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put @@ -476,7 +478,9 @@ decodeChangeCipherSpec :: ByteString -> Either TLSError () decodeChangeCipherSpec = runGetErr "changecipherspec" $ do x <- getWord8 - when (x /= 1) (fail "unknown change cipher spec content") + 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) diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -42,18 +42,18 @@ putBinaryVersion TLS12 putServerRandom32 random putSession session - putWord16 cipherId + putWord16 $ fromCipherId cipherId putWord8 0 -- compressionID nullCompression putExtensions exts encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts -encodeHandshake13' (Certificate13 reqctx cc ess) = encodeCertificate13 reqctx cc ess -encodeHandshake13' (CertVerify13 hs signature) = runPut $ do +encodeHandshake13' (Certificate13 reqctx (TLSCertificateChain cc) ess) = encodeCertificate13 reqctx cc ess +encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do putSignatureHashAlgorithm hs - putOpaque16 signature -encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat + putOpaque16 sig +encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do putWord32 life putWord32 ageadd @@ -105,13 +105,13 @@ _ver <- getBinaryVersion random <- getServerRandom32 session <- getSession - cipherid <- getWord16 + cipherid <- CipherId <$> getWord16 _comp <- getWord8 exts <- fromIntegral <$> getWord16 >>= getExtensions return $ ServerHello13 random session cipherid exts decodeFinished13 :: Get Handshake13 -decodeFinished13 = Finished13 <$> (remaining >>= getBytes) +decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 = @@ -133,7 +133,7 @@ (certRaws, ess) <- unzip <$> getList len getCert case decodeCertificateChain $ CertificateChainRaw certRaws of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) - Right cc -> return $ Certificate13 reqctx cc ess + Right cc -> return $ Certificate13 reqctx (TLSCertificateChain cc) ess where getCert = do l <- fromIntegral <$> getWord24 @@ -143,7 +143,8 @@ return (3 + l + 2 + len, (cert, exts)) decodeCertVerify13 :: Get Handshake13 -decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16 +decodeCertVerify13 = + CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) decodeNewSessionTicket13 :: Get Handshake13 decodeNewSessionTicket13 = do diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -331,7 +331,7 @@ -- The default value includes all groups with security strength of 128 -- bits or more. -- - -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ + -- Default: @[X25519,X448,P256,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ } deriving (Show, Eq) @@ -646,7 +646,9 @@ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" , onUnverifiedClientCert = return False - , onCipherChoosing = \_ -> head + , onCipherChoosing = \_ ccs -> case ccs of + [] -> error "onCipherChoosing" + c : _ -> c , onServerNameIndication = \_ -> return mempty , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -74,6 +74,7 @@ import Network.TLS.Core import Network.TLS.Crypto (hashDigestSize) import Network.TLS.Crypto.Types +import Network.TLS.Extension import Network.TLS.Extra.Cipher import Network.TLS.Handshake.Common import Network.TLS.Handshake.Control @@ -246,9 +247,9 @@ def { supportedVersions = [TLS13] , supportedCiphers = - [ cipher_TLS13_AES256GCM_SHA384 - , cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES128CCM_SHA256 + [ cipher13_AES_256_GCM_SHA384 + , cipher13_AES_128_GCM_SHA256 + , cipher13_AES_128_CCM_SHA256 ] , supportedGroups = [X25519, X448, P256, P384, P521] } diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -67,7 +67,10 @@ ---------------------------------------------------------------- processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) -processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13 +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 diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -45,6 +45,15 @@ 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) diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -37,6 +37,7 @@ setClientEcPointFormatSuggest, getClientEcPointFormatSuggest, setClientSNI, + clearClientSNI, getClientSNI, getClientCertificateChain, setClientCertificateChain, @@ -277,30 +278,33 @@ setClientSNI :: HostName -> TLSSt () setClientSNI hn = modify (\st -> st{stClientSNI = Just hn}) +clearClientSNI :: TLSSt () +clearClientSNI = modify (\st -> st{stClientSNI = Nothing}) + getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI -getVerifyData :: Role -> TLSSt ByteString +getVerifyData :: Role -> TLSSt VerifyData getVerifyData client = do mVerifyData <- gets (if client == ClientRole then stClientVerifyData else stServerVerifyData) - return $ fromMaybe "" mVerifyData + return $ fromMaybe (VerifyData "") mVerifyData -getMyVerifyData :: TLSSt (Maybe ByteString) +getMyVerifyData :: TLSSt (Maybe VerifyData) getMyVerifyData = do role <- getRole if role == ClientRole then gets stClientVerifyData else gets stServerVerifyData -getPeerVerifyData :: TLSSt (Maybe ByteString) +getPeerVerifyData :: TLSSt (Maybe VerifyData) getPeerVerifyData = do role <- getRole if role == ClientRole then gets stServerVerifyData else gets stClientVerifyData -getFirstVerifyData :: TLSSt (Maybe ByteString) +getFirstVerifyData :: TLSSt (Maybe VerifyData) getFirstVerifyData = do ver <- getVersion case ver of diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -7,47 +6,6 @@ module Network.TLS.Struct ( Version (..), CipherData (..), - ExtensionID ( - .., - EID_ServerName, - EID_MaxFragmentLength, - EID_ClientCertificateUrl, - EID_TrustedCAKeys, - EID_TruncatedHMAC, - EID_StatusRequest, - EID_UserMapping, - EID_ClientAuthz, - EID_ServerAuthz, - EID_CertType, - EID_SupportedGroups, - EID_EcPointFormats, - EID_SRP, - EID_SignatureAlgorithms, - EID_SRTP, - EID_Heartbeat, - EID_ApplicationLayerProtocolNegotiation, - EID_StatusRequestv2, - EID_SignedCertificateTimestamp, - EID_ClientCertificateType, - EID_ServerCertificateType, - EID_Padding, - EID_EncryptThenMAC, - EID_ExtendedMainSecret, - EID_SessionTicket, - EID_PreSharedKey, - EID_EarlyData, - EID_SupportedVersions, - EID_Cookie, - EID_PskKeyExchangeModes, - EID_CertificateAuthorities, - EID_OidFilters, - EID_PostHandshakeAuth, - EID_SignatureAlgorithmsCert, - EID_KeyShare, - EID_QuicTransportParameters, - EID_SecureRenegotiation - ), - ExtensionRaw (..), CertificateType ( CertificateType, CertificateType_RSA_Sign, @@ -58,34 +16,6 @@ ), fromCertificateType, lastSupportedCertificateType, - HashAlgorithm ( - .., - HashNone, - HashMD5, - HashSHA1, - HashSHA224, - HashSHA256, - HashSHA384, - HashSHA512, - HashIntrinsic - ), - SignatureAlgorithm ( - .., - SignatureAnonymous, - SignatureRSA, - SignatureDSA, - SignatureECDSA, - SignatureRSApssRSAeSHA256, - SignatureRSApssRSAeSHA384, - SignatureRSApssRSAeSHA512, - SignatureEd25519, - SignatureEd448, - SignatureRSApsspssSHA256, - SignatureRSApsspssSHA384, - SignatureRSApsspssSHA512 - ), - HashAndSignatureAlgorithm, - supportedSignatureSchemes, DigitallySigned (..), Signature, ProtocolType ( @@ -98,9 +28,6 @@ TLSError (..), TLSException (..), DistinguishedName, - BigNum (..), - bigNumToInteger, - bigNumFromInteger, ServerDHParams (..), serverDHParamsToParams, serverDHParamsToPublic, @@ -114,7 +41,7 @@ ServerRandom (..), ClientRandom (..), FinishedData, - VerifyData, + VerifyData (..), SessionID, Session (..), SessionData (..), @@ -176,21 +103,24 @@ HandshakeType_Finished, HandshakeType_KeyUpdate ), + TLSCertificateChain (..), Handshake (..), CH (..), packetType, typeOfHandshake, + module Network.TLS.HashAndSignature, + ExtensionRaw (..), + ExtensionID (..), ) where -import Control.Exception (Exception (..)) -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Char8 as C8 -import Data.Typeable import Data.X509 (CertificateChain, DistinguishedName) + import Network.TLS.Crypto +import Network.TLS.Error +import {-# SOURCE #-} Network.TLS.Extension +import Network.TLS.HashAndSignature import Network.TLS.Imports import Network.TLS.Types -import Network.TLS.Util.Serialization ---------------------------------------------------------------- @@ -250,122 +180,14 @@ ------------------------------------------------------------ -newtype HashAlgorithm = HashAlgorithm {fromHashAlgorithm :: Word8} - deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern HashNone :: HashAlgorithm -pattern HashNone = HashAlgorithm 0 -pattern HashMD5 :: HashAlgorithm -pattern HashMD5 = HashAlgorithm 1 -pattern HashSHA1 :: HashAlgorithm -pattern HashSHA1 = HashAlgorithm 2 -pattern HashSHA224 :: HashAlgorithm -pattern HashSHA224 = HashAlgorithm 3 -pattern HashSHA256 :: HashAlgorithm -pattern HashSHA256 = HashAlgorithm 4 -pattern HashSHA384 :: HashAlgorithm -pattern HashSHA384 = HashAlgorithm 5 -pattern HashSHA512 :: HashAlgorithm -pattern HashSHA512 = HashAlgorithm 6 -pattern HashIntrinsic :: HashAlgorithm -pattern HashIntrinsic = HashAlgorithm 8 - -instance Show HashAlgorithm where - show HashNone = "HashNone" - show HashMD5 = "HashMD5" - show HashSHA1 = "HashSHA1" - show HashSHA224 = "HashSHA224" - show HashSHA256 = "HashSHA256" - show HashSHA384 = "HashSHA384" - show HashSHA512 = "HashSHA512" - show HashIntrinsic = "HashIntrinsic" - show (HashAlgorithm x) = "HashAlgorithm " ++ show x -{- FOURMOLU_ENABLE -} - ------------------------------------------------------------- - -newtype SignatureAlgorithm = SignatureAlgorithm {fromSignatureAlgorithm :: Word8} - deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern SignatureAnonymous :: SignatureAlgorithm -pattern SignatureAnonymous = SignatureAlgorithm 0 -pattern SignatureRSA :: SignatureAlgorithm -pattern SignatureRSA = SignatureAlgorithm 1 -pattern SignatureDSA :: SignatureAlgorithm -pattern SignatureDSA = SignatureAlgorithm 2 -pattern SignatureECDSA :: SignatureAlgorithm -pattern SignatureECDSA = SignatureAlgorithm 3 --- TLS 1.3 from here -pattern SignatureRSApssRSAeSHA256 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA256 = SignatureAlgorithm 4 -pattern SignatureRSApssRSAeSHA384 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA384 = SignatureAlgorithm 5 -pattern SignatureRSApssRSAeSHA512 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA512 = SignatureAlgorithm 6 -pattern SignatureEd25519 :: SignatureAlgorithm -pattern SignatureEd25519 = SignatureAlgorithm 7 -pattern SignatureEd448 :: SignatureAlgorithm -pattern SignatureEd448 = SignatureAlgorithm 8 -pattern SignatureRSApsspssSHA256 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA256 = SignatureAlgorithm 9 -pattern SignatureRSApsspssSHA384 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA384 = SignatureAlgorithm 10 -pattern SignatureRSApsspssSHA512 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA512 = SignatureAlgorithm 11 - -instance Show SignatureAlgorithm where - show SignatureAnonymous = "SignatureAnonymous" - show SignatureRSA = "SignatureRSA" - show SignatureDSA = "SignatureDSA" - show SignatureECDSA = "SignatureECDSA" - show SignatureRSApssRSAeSHA256 = "SignatureRSApssRSAeSHA256" - show SignatureRSApssRSAeSHA384 = "SignatureRSApssRSAeSHA384" - show SignatureRSApssRSAeSHA512 = "SignatureRSApssRSAeSHA512" - show SignatureEd25519 = "SignatureEd25519" - show SignatureEd448 = "SignatureEd448" - show SignatureRSApsspssSHA256 = "SignatureRSApsspssSHA256" - show SignatureRSApsspssSHA384 = "SignatureRSApsspssSHA384" - show SignatureRSApsspssSHA512 = "SignatureRSApsspssSHA512" - show (SignatureAlgorithm x) = "SignatureAlgorithm " ++ show x -{- FOURMOLU_ENABLE -} - ------------------------------------------------------------- - -type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) - -{- FOURMOLU_DISABLE -} -supportedSignatureSchemes :: [HashAndSignatureAlgorithm] -supportedSignatureSchemes = - -- EdDSA algorithms - [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) - , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) - -- ECDSA algorithms - , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403) - , (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) - -- RSASSA-PKCS1-v1_5 algorithms - , (HashSHA512, SignatureRSA) -- rsa_pkcs1_sha512(0x0601) - , (HashSHA384, SignatureRSA) -- rsa_pkcs1_sha384(0x0501) - , (HashSHA256, SignatureRSA) -- rsa_pkcs1_sha256(0x0401) - -- Legacy algorithms - , (HashSHA1, SignatureRSA) -- rsa_pkcs1_sha1 (0x0201) - , (HashSHA1, SignatureECDSA) -- ecdsa_sha1 (0x0203) - ] -{- FOURMOLU_ENABLE -} - ------------------------------------------------------------- - type Signature = ByteString data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature - deriving (Show, Eq) + deriving (Eq) +instance Show DigitallySigned where + show (DigitallySigned hs sig) = "DigitallySigned " ++ show hs ++ " " ++ showBytesHex sig + ---------------------------------------------------------------- newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq) @@ -393,62 +215,6 @@ ---------------------------------------------------------------- --- | TLSError that might be returned through the TLS stack. --- --- Prior to version 1.8.0, this type had an @Exception@ instance. --- In version 1.8.0, this instance was removed, and functions in --- this library now only throw 'TLSException'. -data TLSError - = -- | mainly for instance of Error - Error_Misc String - | -- | A fatal error condition was encountered at a low level. The - -- elements of the tuple give (freeform text description, structured - -- error description). - Error_Protocol String AlertDescription - | -- | A non-fatal error condition was encountered at a low level at a low - -- level. The elements of the tuple give (freeform text description, - -- structured error description). - Error_Protocol_Warning String AlertDescription - | Error_Certificate String - | -- | handshake policy failed. - Error_HandshakePolicy String - | Error_EOF - | Error_Packet String - | Error_Packet_unexpected String String - | Error_Packet_Parsing String - deriving (Eq, Show, Typeable) - ----------------------------------------------------------------- - --- | TLS Exceptions. Some of the data constructors indicate incorrect use of --- the library, and the documentation for those data constructors calls --- this out. The others wrap 'TLSError' with some kind of context to explain --- when the exception occurred. -data TLSException - = -- | Early termination exception with the reason and the error associated - Terminated Bool String TLSError - | -- | Handshake failed for the reason attached. - HandshakeFailed TLSError - | -- | Failure occurred while sending or receiving data after the - -- TLS handshake succeeded. - PostHandshake TLSError - | -- | Lifts a 'TLSError' into 'TLSException' without provided any context - -- around when the error happened. - Uncontextualized TLSError - | -- | Usage error when the connection has not been established - -- and the user is trying to send or receive data. - -- Indicates that this library has been used incorrectly. - ConnectionNotEstablished - | -- | Expected that a TLS handshake had already taken place, but no TLS - -- handshake had occurred. - -- Indicates that this library has been used incorrectly. - MissingHandshake - deriving (Show, Eq, Typeable) - -instance Exception TLSException - ----------------------------------------------------------------- - data Packet = Handshake [Handshake] | Alert [(AlertLevel, AlertDescription)] @@ -460,280 +226,32 @@ show (Handshake hs) = "Handshake " ++ show hs show (Alert as) = "Alert " ++ show as show ChangeCipherSpec = "ChangeCipherSpec" - show (AppData bs) = "AppData " ++ C8.unpack (B16.encode bs) + show (AppData bs) = "AppData " ++ showBytesHex bs data Header = Header ProtocolType Version Word16 deriving (Show, Eq) newtype ServerRandom = ServerRandom {unServerRandom :: ByteString} - deriving (Show, Eq) -newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} - deriving (Show, Eq) -newtype Session = Session (Maybe SessionID) deriving (Show, Eq) - -{-# DEPRECATED FinishedData "use VerifyData" #-} -type FinishedData = ByteString -type VerifyData = ByteString - ----------------------------------------------------------------- - --- | Identifier of a TLS extension. --- -newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern EID_ServerName :: ExtensionID -- RFC6066 -pattern EID_ServerName = ExtensionID 0x0 -pattern EID_MaxFragmentLength :: ExtensionID -- RFC6066 -pattern EID_MaxFragmentLength = ExtensionID 0x1 -pattern EID_ClientCertificateUrl :: ExtensionID -- RFC6066 -pattern EID_ClientCertificateUrl = ExtensionID 0x2 -pattern EID_TrustedCAKeys :: ExtensionID -- RFC6066 -pattern EID_TrustedCAKeys = ExtensionID 0x3 -pattern EID_TruncatedHMAC :: ExtensionID -- RFC6066 -pattern EID_TruncatedHMAC = ExtensionID 0x4 -pattern EID_StatusRequest :: ExtensionID -- RFC6066 -pattern EID_StatusRequest = ExtensionID 0x5 -pattern EID_UserMapping :: ExtensionID -- RFC4681 -pattern EID_UserMapping = ExtensionID 0x6 -pattern EID_ClientAuthz :: ExtensionID -- RFC5878 -pattern EID_ClientAuthz = ExtensionID 0x7 -pattern EID_ServerAuthz :: ExtensionID -- RFC5878 -pattern EID_ServerAuthz = ExtensionID 0x8 -pattern EID_CertType :: ExtensionID -- RFC6091 -pattern EID_CertType = ExtensionID 0x9 -pattern EID_SupportedGroups :: ExtensionID -- RFC8422,8446 -pattern EID_SupportedGroups = ExtensionID 0xa -pattern EID_EcPointFormats :: ExtensionID -- RFC4492 -pattern EID_EcPointFormats = ExtensionID 0xb -pattern EID_SRP :: ExtensionID -- RFC5054 -pattern EID_SRP = ExtensionID 0xc -pattern EID_SignatureAlgorithms :: ExtensionID -- RFC5246,8446 -pattern EID_SignatureAlgorithms = ExtensionID 0xd -pattern EID_SRTP :: ExtensionID -- RFC5764 -pattern EID_SRTP = ExtensionID 0xe -pattern EID_Heartbeat :: ExtensionID -- RFC6520 -pattern EID_Heartbeat = ExtensionID 0xf -pattern EID_ApplicationLayerProtocolNegotiation :: ExtensionID -- RFC7301 -pattern EID_ApplicationLayerProtocolNegotiation = ExtensionID 0x10 -pattern EID_StatusRequestv2 :: ExtensionID -- RFC6961 -pattern EID_StatusRequestv2 = ExtensionID 0x11 -pattern EID_SignedCertificateTimestamp :: ExtensionID -- RFC6962 -pattern EID_SignedCertificateTimestamp = ExtensionID 0x12 -pattern EID_ClientCertificateType :: ExtensionID -- RFC7250 -pattern EID_ClientCertificateType = ExtensionID 0x13 -pattern EID_ServerCertificateType :: ExtensionID -- RFC7250 -pattern EID_ServerCertificateType = ExtensionID 0x14 -pattern EID_Padding :: ExtensionID -- RFC5246 -pattern EID_Padding = ExtensionID 0x15 -pattern EID_EncryptThenMAC :: ExtensionID -- RFC7366 -pattern EID_EncryptThenMAC = ExtensionID 0x16 -pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627 -pattern EID_ExtendedMainSecret = ExtensionID 0x17 -pattern EID_SessionTicket :: ExtensionID -- RFC4507 -pattern EID_SessionTicket = ExtensionID 0x23 -pattern EID_PreSharedKey :: ExtensionID -- RFC8446 -pattern EID_PreSharedKey = ExtensionID 0x29 -pattern EID_EarlyData :: ExtensionID -- RFC8446 -pattern EID_EarlyData = ExtensionID 0x2a -pattern EID_SupportedVersions :: ExtensionID -- RFC8446 -pattern EID_SupportedVersions = ExtensionID 0x2b -pattern EID_Cookie :: ExtensionID -- RFC8446 -pattern EID_Cookie = ExtensionID 0x2c -pattern EID_PskKeyExchangeModes :: ExtensionID -- RFC8446 -pattern EID_PskKeyExchangeModes = ExtensionID 0x2d -pattern EID_CertificateAuthorities :: ExtensionID -- RFC8446 -pattern EID_CertificateAuthorities = ExtensionID 0x2f -pattern EID_OidFilters :: ExtensionID -- RFC8446 -pattern EID_OidFilters = ExtensionID 0x30 -pattern EID_PostHandshakeAuth :: ExtensionID -- RFC8446 -pattern EID_PostHandshakeAuth = ExtensionID 0x31 -pattern EID_SignatureAlgorithmsCert :: ExtensionID -- RFC8446 -pattern EID_SignatureAlgorithmsCert = ExtensionID 0x32 -pattern EID_KeyShare :: ExtensionID -- RFC8446 -pattern EID_KeyShare = ExtensionID 0x33 -pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001 -pattern EID_QuicTransportParameters = ExtensionID 0x39 -pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746 -pattern EID_SecureRenegotiation = ExtensionID 0xff01 - -instance Show ExtensionID where - show EID_ServerName = "ServerName" - show EID_MaxFragmentLength = "MaxFragmentLength" - show EID_ClientCertificateUrl = "ClientCertificateUrl" - show EID_TrustedCAKeys = "TrustedCAKeys" - show EID_TruncatedHMAC = "TruncatedHMAC" - show EID_StatusRequest = "StatusRequest" - show EID_UserMapping = "UserMapping" - show EID_ClientAuthz = "ClientAuthz" - show EID_ServerAuthz = "ServerAuthz" - show EID_CertType = "CertType" - show EID_SupportedGroups = "SupportedGroups" - show EID_EcPointFormats = "EcPointFormats" - show EID_SRP = "SRP" - show EID_SignatureAlgorithms = "SignatureAlgorithms" - show EID_SRTP = "SRTP" - show EID_Heartbeat = "Heartbeat" - show EID_ApplicationLayerProtocolNegotiation = "ApplicationLayerProtocolNegotiation" - show EID_StatusRequestv2 = "StatusRequestv2" - show EID_SignedCertificateTimestamp = "SignedCertificateTimestamp" - show EID_ClientCertificateType = "ClientCertificateType" - show EID_ServerCertificateType = "ServerCertificateType" - show EID_Padding = "Padding" - show EID_EncryptThenMAC = "EncryptThenMAC" - show EID_ExtendedMainSecret = "ExtendedMainSecret" - show EID_SessionTicket = "SessionTicket" - show EID_PreSharedKey = "PreSharedKey" - show EID_EarlyData = "EarlyData" - show EID_SupportedVersions = "SupportedVersions" - show EID_Cookie = "Cookie" - show EID_PskKeyExchangeModes = "PskKeyExchangeModes" - show EID_CertificateAuthorities = "CertificateAuthorities" - show EID_OidFilters = "OidFilters" - show EID_PostHandshakeAuth = "PostHandshakeAuth" - show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert" - show EID_KeyShare = "KeyShare" - show EID_QuicTransportParameters = "QuicTransportParameters" - show EID_SecureRenegotiation = "SecureRenegotiation" - show (ExtensionID x) = "ExtensionID " ++ show x -{- FOURMOLU_ENABLE -} - ----------------------------------------------------------------- - --- | The raw content of a TLS extension. -data ExtensionRaw = ExtensionRaw ExtensionID ByteString deriving (Eq) - -instance Show ExtensionRaw where - show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs - ----------------------------------------------------------------- - -newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern AlertLevel_Warning :: AlertLevel -pattern AlertLevel_Warning = AlertLevel 1 -pattern AlertLevel_Fatal :: AlertLevel -pattern AlertLevel_Fatal = AlertLevel 2 +instance Show ServerRandom where + show (ServerRandom bs) = "ServerRandom " ++ showBytesHex bs -instance Show AlertLevel where - show AlertLevel_Warning = "AlertLevel_Warning" - show AlertLevel_Fatal = "AlertLevel_Fatal" - show (AlertLevel x) = "AlertLevel " ++ show x -{- FOURMOLU_ENABLE -} +newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} + deriving (Eq) ----------------------------------------------------------------- +instance Show ClientRandom where + show (ClientRandom bs) = "ClientRandom " ++ showBytesHex bs -newtype AlertDescription = AlertDescription {fromAlertDescription :: Word8} - deriving (Eq) +newtype Session = Session (Maybe SessionID) deriving (Eq) +instance Show Session where + show (Session Nothing) = "Session \"\"" + show (Session (Just bs)) = "Session " ++ showBytesHex bs -{- FOURMOLU_DISABLE -} -pattern CloseNotify :: AlertDescription -pattern CloseNotify = AlertDescription 0 -pattern UnexpectedMessage :: AlertDescription -pattern UnexpectedMessage = AlertDescription 10 -pattern BadRecordMac :: AlertDescription -pattern BadRecordMac = AlertDescription 20 -pattern DecryptionFailed :: AlertDescription -pattern DecryptionFailed = AlertDescription 21 -pattern RecordOverflow :: AlertDescription -pattern RecordOverflow = AlertDescription 22 -pattern DecompressionFailure :: AlertDescription -pattern DecompressionFailure = AlertDescription 30 -pattern HandshakeFailure :: AlertDescription -pattern HandshakeFailure = AlertDescription 40 -pattern BadCertificate :: AlertDescription -pattern BadCertificate = AlertDescription 42 -pattern UnsupportedCertificate :: AlertDescription -pattern UnsupportedCertificate = AlertDescription 43 -pattern CertificateRevoked :: AlertDescription -pattern CertificateRevoked = AlertDescription 44 -pattern CertificateExpired :: AlertDescription -pattern CertificateExpired = AlertDescription 45 -pattern CertificateUnknown :: AlertDescription -pattern CertificateUnknown = AlertDescription 46 -pattern IllegalParameter :: AlertDescription -pattern IllegalParameter = AlertDescription 47 -pattern UnknownCa :: AlertDescription -pattern UnknownCa = AlertDescription 48 -pattern AccessDenied :: AlertDescription -pattern AccessDenied = AlertDescription 49 -pattern DecodeError :: AlertDescription -pattern DecodeError = AlertDescription 50 -pattern DecryptError :: AlertDescription -pattern DecryptError = AlertDescription 51 -pattern ExportRestriction :: AlertDescription -pattern ExportRestriction = AlertDescription 60 -pattern ProtocolVersion :: AlertDescription -pattern ProtocolVersion = AlertDescription 70 -pattern InsufficientSecurity :: AlertDescription -pattern InsufficientSecurity = AlertDescription 71 -pattern InternalError :: AlertDescription -pattern InternalError = AlertDescription 80 -pattern InappropriateFallback :: AlertDescription -pattern InappropriateFallback = AlertDescription 86 -- RFC7507 -pattern UserCanceled :: AlertDescription -pattern UserCanceled = AlertDescription 90 -pattern NoRenegotiation :: AlertDescription -pattern NoRenegotiation = AlertDescription 100 -pattern MissingExtension :: AlertDescription -pattern MissingExtension = AlertDescription 109 -pattern UnsupportedExtension :: AlertDescription -pattern UnsupportedExtension = AlertDescription 110 -pattern CertificateUnobtainable :: AlertDescription -pattern CertificateUnobtainable = AlertDescription 111 -pattern UnrecognizedName :: AlertDescription -pattern UnrecognizedName = AlertDescription 112 -pattern BadCertificateStatusResponse :: AlertDescription -pattern BadCertificateStatusResponse = AlertDescription 113 -pattern BadCertificateHashValue :: AlertDescription -pattern BadCertificateHashValue = AlertDescription 114 -pattern UnknownPskIdentity :: AlertDescription -pattern UnknownPskIdentity = AlertDescription 115 -pattern CertificateRequired :: AlertDescription -pattern CertificateRequired = AlertDescription 116 -pattern GeneralError :: AlertDescription -pattern GeneralError = AlertDescription 117 -pattern NoApplicationProtocol :: AlertDescription -pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301 +{-# DEPRECATED FinishedData "use VerifyData" #-} +type FinishedData = ByteString -instance Show AlertDescription where - show CloseNotify = "CloseNotify" - show UnexpectedMessage = "UnexpectedMessage" - show BadRecordMac = "BadRecordMac" - show DecryptionFailed = "DecryptionFailed" - show RecordOverflow = "RecordOverflow" - show DecompressionFailure = "DecompressionFailure" - show HandshakeFailure = "HandshakeFailure" - show BadCertificate = "BadCertificate" - show UnsupportedCertificate = "UnsupportedCertificate" - show CertificateRevoked = "CertificateRevoked" - show CertificateExpired = "CertificateExpired" - show CertificateUnknown = "CertificateUnknown" - show IllegalParameter = "IllegalParameter" - show UnknownCa = "UnknownCa" - show AccessDenied = "AccessDenied" - show DecodeError = "DecodeError" - show DecryptError = "DecryptError" - show ExportRestriction = "ExportRestriction" - show ProtocolVersion = "ProtocolVersion" - show InsufficientSecurity = "InsufficientSecurity" - show InternalError = "InternalError" - show InappropriateFallback = "InappropriateFallback" - show UserCanceled = "UserCanceled" - show NoRenegotiation = "NoRenegotiation" - show MissingExtension = "MissingExtension" - show UnsupportedExtension = "UnsupportedExtension" - show CertificateUnobtainable = "CertificateUnobtainable" - show UnrecognizedName = "UnrecognizedName" - show BadCertificateStatusResponse = "BadCertificateStatusResponse" - show BadCertificateHashValue = "BadCertificateHashValue" - show UnknownPskIdentity = "UnknownPskIdentity" - show CertificateRequired = "CertificateRequired" - show GeneralError = "GeneralError" - show NoApplicationProtocol = "NoApplicationProtocol" - show (AlertDescription x) = "AlertDescription " ++ show x -{- FOURMOLU_ENABLE -} +newtype VerifyData = VerifyData ByteString deriving (Eq) +instance Show VerifyData where + show (VerifyData bs) = showBytesHex bs ---------------------------------------------------------------- @@ -787,17 +305,6 @@ ---------------------------------------------------------------- -newtype BigNum = BigNum ByteString - deriving (Show, Eq) - -bigNumToInteger :: BigNum -> Integer -bigNumToInteger (BigNum b) = os2ip b - -bigNumFromInteger :: Integer -> BigNum -bigNumFromInteger i = BigNum $ i2osp i - ----------------------------------------------------------------- - data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum @@ -852,25 +359,48 @@ | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown ByteString - deriving (Show, Eq) + deriving (Eq) +{- FOURMOLU_DISABLE -} +instance Show ServerKeyXchgAlgorithmData where + show (SKX_DH_Anon _) = "SKX_DH_Anon" + show (SKX_DHE_DSA _ _) = "SKX_DHE_DSA" + show (SKX_DHE_RSA _ _) = "SKX_DHE_RSA" + show (SKX_ECDHE_RSA _ _) = "SKX_ECDHE_RSA" + show (SKX_ECDHE_ECDSA _ _) = "SKX_ECDHE_ECDSA" + show (SKX_RSA _) = "SKX_RSA" + show (SKX_DH_DSA _) = "SKX_DH_DSA" + show (SKX_DH_RSA _) = "SKX_DH_RSA" + show (SKX_Unparsed _) = "SKX_Unparsed" + show (SKX_Unknown _) = "SKX_Unknown" +{- FOURMOLU_ENABLE -} + ---------------------------------------------------------------- data ClientKeyXchgAlgorithmData = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString - deriving (Show, Eq) + deriving (Eq) +instance Show ClientKeyXchgAlgorithmData where + show (CKX_RSA bs) = "CKX_RSA " ++ showBytesHex bs + show (CKX_DH pub) = "CKX_DH " ++ show pub + show (CKX_ECDH bs) = "CKX_ECDH " ++ showBytesHex bs + ---------------------------------------------------------------- data CH = CH { chSession :: Session - , chCiphers :: [CipherID] + , chCiphers :: [CipherId] , chExtensions :: [ExtensionRaw] } deriving (Show, Eq) +newtype TLSCertificateChain = TLSCertificateChain CertificateChain deriving (Eq) +instance Show TLSCertificateChain where + show _ = "CertificateChain" + data Handshake = ClientHello Version @@ -881,10 +411,10 @@ Version ServerRandom Session - CipherID + CipherId CompressionID [ExtensionRaw] - | Certificate CertificateChain + | Certificate TLSCertificateChain | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -4,9 +4,9 @@ typeOfHandshake13, contentType, KeyUpdate (..), + CertReqContext, ) where -import Data.X509 (CertificateChain) import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types @@ -27,16 +27,19 @@ -- fixme: convert Word32 to proper data type data Handshake13 - = ServerHello13 ServerRandom Session CipherID [ExtensionRaw] + = ServerHello13 ServerRandom Session CipherId [ExtensionRaw] | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw] | CertRequest13 CertReqContext [ExtensionRaw] - | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]] - | CertVerify13 HashAndSignatureAlgorithm Signature + | Certificate13 CertReqContext TLSCertificateChain [[ExtensionRaw]] + | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate deriving (Show, Eq) + +-- | Certificate request context for TLS 1.3. +type CertReqContext = ByteString {- FOURMOLU_DISABLE -} typeOfHandshake13 :: Handshake13 -> HandshakeType diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -3,188 +3,53 @@ {-# LANGUAGE PatternSynonyms #-} module Network.TLS.Types ( - Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13), - SessionID, - SessionIDorTicket, - Ticket, - isTicket, - toSessionID, - SessionData (..), - is0RTTPossible, - SessionFlag (..), - CertReqContext, - TLS13TicketInfo (..), - CipherID, - CompressionID, + module Network.TLS.Types.Cipher, + module Network.TLS.Types.Secret, + module Network.TLS.Types.Session, + module Network.TLS.Types.Version, + HostName, Role (..), invertRole, Direction (..), - HostName, - Second, - Millisecond, - EarlySecret, - HandshakeSecret, - ApplicationSecret, - ResumptionSecret, - BaseSecret (..), - AnyTrafficSecret (..), - ClientTrafficSecret (..), - ServerTrafficSecret (..), - TrafficSecrets, - SecretTriple (..), - SecretPair (..), - MainSecret (..), + BigNum (..), + bigNumToInteger, + bigNumFromInteger, ) where -import Codec.Serialise -import qualified Data.ByteString as B -import GHC.Generics import Network.Socket (HostName) -import Network.TLS.Crypto (Group, Hash (..), hash) -import Network.TLS.Imports -type Second = Word32 -type Millisecond = Word64 - --- | Versions known to TLS -newtype Version = Version Word16 deriving (Eq, Ord, Generic) -{- FOURMOLU_DISABLE -} -pattern SSL2 :: Version -pattern SSL2 = Version 0x0200 -pattern SSL3 :: Version -pattern SSL3 = Version 0x0300 -pattern TLS10 :: Version -pattern TLS10 = Version 0x0301 -pattern TLS11 :: Version -pattern TLS11 = Version 0x0302 -pattern TLS12 :: Version -pattern TLS12 = Version 0x0303 -pattern TLS13 :: Version -pattern TLS13 = Version 0x0304 - -instance Show Version where - show SSL2 = "SSL2" - show SSL3 = "SSL3" - show TLS10 = "TLS1.0" - show TLS11 = "TLS1.1" - show TLS12 = "TLS1.2" - show TLS13 = "TLS1.3" - show (Version x) = "Version " ++ show x -{- FOURMOLU_ENABLE -} - --- | A session ID -type SessionID = ByteString - --- | Identity -type SessionIDorTicket = ByteString - --- | Encrypted session ticket (encrypt(encode 'SessionData')). -type Ticket = ByteString - -isTicket :: SessionIDorTicket -> Bool -isTicket x - | B.length x > 32 = True - | otherwise = False - -toSessionID :: Ticket -> SessionID -toSessionID = hash SHA256 - --- | Session data to resume -data SessionData = SessionData - { sessionVersion :: Version - , sessionCipher :: CipherID - , sessionCompression :: CompressionID - , sessionClientSNI :: Maybe HostName - , sessionSecret :: ByteString - , sessionGroup :: Maybe Group - , sessionTicketInfo :: Maybe TLS13TicketInfo - , sessionALPN :: Maybe ByteString - , sessionMaxEarlyDataSize :: Int - , sessionFlags :: [SessionFlag] - } -- sessionFromTicket :: Bool - deriving (Show, Eq, Generic) - -is0RTTPossible :: SessionData -> Bool -is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0 - --- | Some session flags -data SessionFlag - = -- | Session created with Extended Main Secret - SessionEMS - deriving (Show, Eq, Enum, Generic) - --- | Certificate request context for TLS 1.3. -type CertReqContext = ByteString - -data TLS13TicketInfo = TLS13TicketInfo - { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds - , ageAdd :: Second -- NewSessionTicket.ticket_age_add - , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime - , estimatedRTT :: Maybe Millisecond - } - deriving (Show, Eq, Generic) - --- | Cipher identification -type CipherID = Word16 +import Network.TLS.Imports +import Network.TLS.Types.Cipher +import Network.TLS.Types.Secret +import Network.TLS.Types.Session +import Network.TLS.Types.Version +import Network.TLS.Util.Serialization --- | Compression identification -type CompressionID = Word8 +---------------------------------------------------------------- -- | Role data Role = ClientRole | ServerRole deriving (Show, Eq) --- | Direction -data Direction = Tx | Rx - deriving (Show, Eq) - invertRole :: Role -> Role invertRole ClientRole = ServerRole invertRole ServerRole = ClientRole --- | Phantom type indicating early traffic secret. -data EarlySecret - --- | Phantom type indicating handshake traffic secrets. -data HandshakeSecret - --- | Phantom type indicating application traffic secrets. -data ApplicationSecret - -data ResumptionSecret - -newtype BaseSecret a = BaseSecret ByteString deriving (Show) -newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show) - --- | A client traffic secret, typed with a parameter indicating a step in the --- TLS key schedule. -newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show) +---------------------------------------------------------------- --- | A server traffic secret, typed with a parameter indicating a step in the --- TLS key schedule. -newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show) +-- | Direction +data Direction = Tx | Rx + deriving (Show, Eq) -data SecretTriple a = SecretTriple - { triBase :: BaseSecret a - , triClient :: ClientTrafficSecret a - , triServer :: ServerTrafficSecret a - } - deriving (Show) +---------------------------------------------------------------- -data SecretPair a = SecretPair - { pairBase :: BaseSecret a - , pairClient :: ClientTrafficSecret a - } +newtype BigNum = BigNum ByteString + deriving (Show, Eq) --- | Hold both client and server traffic secrets at the same step. -type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) +bigNumToInteger :: BigNum -> Integer +bigNumToInteger (BigNum b) = os2ip b --- Main secret for TLS 1.2 or earlier. -newtype MainSecret = MainSecret ByteString deriving (Show) +bigNumFromInteger :: Integer -> BigNum +bigNumFromInteger i = BigNum $ i2osp i ---------------------------------------------------------------- - -instance Serialise Version -instance Serialise TLS13TicketInfo -instance Serialise SessionFlag -instance Serialise SessionData diff --git a/Network/TLS/Types/Cipher.hs b/Network/TLS/Types/Cipher.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Cipher.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + +module Network.TLS.Types.Cipher where + +import Crypto.Cipher.Types (AuthTag) +import Data.IORef +import GHC.Generics +import System.IO.Unsafe (unsafePerformIO) +import Text.Printf + +import Network.TLS.Crypto (Hash (..)) +import Network.TLS.Imports +import Network.TLS.Types.Version + +---------------------------------------------------------------- + +-- | Cipher identification +type CipherID = Word16 + +newtype CipherId = CipherId {fromCipherId :: Word16} + deriving (Eq, Ord, Enum, Num, Integral, Real, Read, Generic) + +instance Show CipherId where + show (CipherId 0x00FF) = "TLS_EMPTY_RENEGOTIATION_INFO_SCSV" + show (CipherId n) = case find eqID dict of + Just c -> cipherName c + Nothing -> printf "0x%04X" n + where + eqID c = cipherID c == n + dict = unsafePerformIO $ readIORef globalCipherDict + +-- "ciphersuite" is designed extensible. +-- So, it's not available from internal modules. +-- This is a compromise to gule "ciphersuite" to Show CipherID. + +{-# NOINLINE globalCipherDict #-} +globalCipherDict :: IORef [Cipher] +globalCipherDict = unsafePerformIO $ newIORef [] + +---------------------------------------------------------------- + +-- | Cipher algorithm +data Cipher = Cipher + { cipherID :: CipherID + , cipherName :: String + , cipherHash :: Hash + , cipherBulk :: Bulk + , cipherKeyExchange :: CipherKeyExchangeType + , cipherMinVer :: Maybe Version + , cipherPRFHash :: Maybe Hash + } + +instance Show Cipher where + show c = cipherName c + +instance Eq Cipher where + (==) c1 c2 = cipherID c1 == cipherID c2 + +---------------------------------------------------------------- + +data CipherKeyExchangeType + = CipherKeyExchange_RSA + | CipherKeyExchange_DH_Anon + | CipherKeyExchange_DHE_RSA + | CipherKeyExchange_ECDHE_RSA + | CipherKeyExchange_DHE_DSA + | CipherKeyExchange_DH_DSA + | CipherKeyExchange_DH_RSA + | CipherKeyExchange_ECDH_ECDSA + | CipherKeyExchange_ECDH_RSA + | CipherKeyExchange_ECDHE_ECDSA + | CipherKeyExchange_TLS13 -- not expressed in cipher suite + deriving (Show, Eq) + +---------------------------------------------------------------- + +data Bulk = Bulk + { bulkName :: String + , bulkKeySize :: Int + , bulkIVSize :: Int + , bulkExplicitIV :: Int -- Explicit size for IV for AEAD Cipher, 0 otherwise + , bulkAuthTagLen :: Int -- Authentication tag length in bytes for AEAD Cipher, 0 otherwise + , bulkBlockSize :: Int + , bulkF :: BulkFunctions + } + +instance Show Bulk where + show bulk = bulkName bulk +instance Eq Bulk where + b1 == b2 = + and + [ bulkName b1 == bulkName b2 + , bulkKeySize b1 == bulkKeySize b2 + , bulkIVSize b1 == bulkIVSize b2 + , bulkBlockSize b1 == bulkBlockSize b2 + ] + +---------------------------------------------------------------- + +data BulkFunctions + = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock) + | BulkStreamF (BulkDirection -> BulkKey -> BulkStream) + | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) + +data BulkDirection = BulkEncrypt | BulkDecrypt + deriving (Show, Eq) + +type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV) + +type BulkKey = ByteString +type BulkIV = ByteString +type BulkNonce = ByteString +type BulkAdditionalData = ByteString + +newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream)) + +type BulkAEAD = + BulkNonce -> ByteString -> BulkAdditionalData -> (ByteString, AuthTag) diff --git a/Network/TLS/Types/Secret.hs b/Network/TLS/Types/Secret.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Secret.hs @@ -0,0 +1,43 @@ +module Network.TLS.Types.Secret where + +import Network.TLS.Imports + +-- | Phantom type indicating early traffic secret. +data EarlySecret + +-- | Phantom type indicating handshake traffic secrets. +data HandshakeSecret + +-- | Phantom type indicating application traffic secrets. +data ApplicationSecret + +data ResumptionSecret + +newtype BaseSecret a = BaseSecret ByteString deriving (Show) +newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show) + +-- | A client traffic secret, typed with a parameter indicating a step in the +-- TLS key schedule. +newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show) + +-- | A server traffic secret, typed with a parameter indicating a step in the +-- TLS key schedule. +newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show) + +data SecretTriple a = SecretTriple + { triBase :: BaseSecret a + , triClient :: ClientTrafficSecret a + , triServer :: ServerTrafficSecret a + } + deriving (Show) + +data SecretPair a = SecretPair + { pairBase :: BaseSecret a + , pairClient :: ClientTrafficSecret a + } + +-- | Hold both client and server traffic secrets at the same step. +type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) + +-- Main secret for TLS 1.2 or earlier. +newtype MainSecret = MainSecret ByteString deriving (Show) diff --git a/Network/TLS/Types/Session.hs b/Network/TLS/Types/Session.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Session.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Network.TLS.Types.Session where + +import Codec.Serialise +import qualified Data.ByteString as B +import GHC.Generics +import Network.Socket (HostName) + +import Network.TLS.Crypto (Group, Hash (..), hash) +import Network.TLS.Imports +import Network.TLS.Types.Cipher +import Network.TLS.Types.Version + +-- | A session ID +type SessionID = ByteString + +-- | Identity +type SessionIDorTicket = ByteString + +-- | Encrypted session ticket (encrypt(encode 'SessionData')). +type Ticket = ByteString + +isTicket :: SessionIDorTicket -> Bool +isTicket x + | B.length x > 32 = True + | otherwise = False + +toSessionID :: Ticket -> SessionID +toSessionID = hash SHA256 + +-- | Compression identification +type CompressionID = Word8 + +-- | Session data to resume +data SessionData = SessionData + { sessionVersion :: Version + , sessionCipher :: CipherID + , sessionCompression :: CompressionID + , sessionClientSNI :: Maybe HostName + , sessionSecret :: ByteString + , sessionGroup :: Maybe Group + , sessionTicketInfo :: Maybe TLS13TicketInfo + , sessionALPN :: Maybe ByteString + , sessionMaxEarlyDataSize :: Int + , sessionFlags :: [SessionFlag] + } -- sessionFromTicket :: Bool + deriving (Show, Eq, Generic) + +is0RTTPossible :: SessionData -> Bool +is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0 + +-- | Some session flags +data SessionFlag + = -- | Session created with Extended Main Secret + SessionEMS + deriving (Show, Eq, Enum, Generic) + +type Second = Word32 +type Millisecond = Word64 + +data TLS13TicketInfo = TLS13TicketInfo + { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds + , ageAdd :: Second -- NewSessionTicket.ticket_age_add + , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime + , estimatedRTT :: Maybe Millisecond + } + deriving (Show, Eq, Generic) + +instance Serialise TLS13TicketInfo +instance Serialise SessionFlag +instance Serialise SessionData diff --git a/Network/TLS/Types/Version.hs b/Network/TLS/Types/Version.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Types/Version.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} + +module Network.TLS.Types.Version ( + Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13), +) where + +import Codec.Serialise +import GHC.Generics + +import Network.TLS.Imports + +-- | Versions known to TLS +newtype Version = Version Word16 deriving (Eq, Ord, Generic) + +{- FOURMOLU_DISABLE -} +pattern SSL2 :: Version +pattern SSL2 = Version 0x0200 +pattern SSL3 :: Version +pattern SSL3 = Version 0x0300 +pattern TLS10 :: Version +pattern TLS10 = Version 0x0301 +pattern TLS11 :: Version +pattern TLS11 = Version 0x0302 +pattern TLS12 :: Version +pattern TLS12 = Version 0x0303 +pattern TLS13 :: Version +pattern TLS13 = Version 0x0304 + +instance Show Version where + show SSL2 = "SSL2" + show SSL3 = "SSL3" + show TLS10 = "TLS1.0" + show TLS11 = "TLS1.1" + show TLS12 = "TLS1.2" + show TLS13 = "TLS1.3" + show (Version x) = "Version " ++ show x +{- FOURMOLU_ENABLE -} + +instance Serialise Version diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -50,8 +50,10 @@ import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put + +import Network.TLS.Error import Network.TLS.Imports -import Network.TLS.Struct +import Network.TLS.Types import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a @@ -91,7 +93,10 @@ getWord16 = getWord16be getWords16 :: Get [Word16] -getWords16 = getWord16 >>= \lenb -> replicateM (fromIntegral lenb `div` 2) getWord16 +getWords16 = do + lenb <- getWord16 + when (odd lenb) $ fail "length for ciphers must be even" + replicateM (fromIntegral lenb `shiftR` 1) getWord16 getWord24 :: Get Int getWord24 = do diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -5,7 +5,6 @@ import Control.Monad import qualified Data.ByteString as B -import Data.Default (def) import Data.List import Data.Word import Data.X509 ( @@ -56,7 +55,7 @@ arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where - arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32 + arbitrary = DigitallySigned <$> (unsafeHead <$> arbitrary) <*> genByteString 32 instance Arbitrary ExtensionRaw where arbitrary = @@ -71,6 +70,9 @@ , CertificateType_ECDSA_Sign ] +instance Arbitrary CipherId where + arbitrary = CipherId <$> arbitrary + instance Arbitrary Handshake where arbitrary = oneof @@ -78,7 +80,7 @@ ClientHello ver <$> arbitrary <*> arbitraryCompressionIDs - <*> (CH <$> arbitrary <*> arbitraryCiphersIDs <*> arbitraryHelloExtensions ver) + <*> (CH <$> arbitrary <*> arbitraryCiphersIds <*> arbitraryHelloExtensions ver) , arbitrary >>= \ver -> ServerHello ver <$> arbitrary @@ -86,13 +88,14 @@ <*> arbitrary <*> arbitrary <*> arbitraryHelloExtensions ver - , Certificate . CertificateChain <$> resize 2 (listOf arbitraryX509) + , Certificate . TLSCertificateChain . CertificateChain + <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 , CertRequest <$> arbitrary <*> arbitrary <*> listOf arbitraryDN , CertVerify <$> arbitrary - , Finished <$> genByteString 12 + , Finished . VerifyData <$> genByteString 12 ] instance Arbitrary Handshake13 where @@ -118,17 +121,21 @@ , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 <$> arbitraryCertReqContext - <*> return (CertificateChain certs) + <*> return (TLSCertificateChain (CertificateChain certs)) <*> replicateM (length certs) arbitrary - , CertVerify13 <$> (head <$> arbitrary) <*> genByteString 32 - , Finished13 <$> genByteString 12 + , CertVerify13 + <$> ( DigitallySigned + <$> (unsafeHead <$> arbitrary) + <*> genByteString 32 + ) + , Finished13 . VerifyData <$> genByteString 12 , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] ---------------------------------------------------------------- -arbitraryCiphersIDs :: Gen [Word16] -arbitraryCiphersIDs = choose (0, 200) >>= vector +arbitraryCiphersIds :: Gen [CipherId] +arbitraryCiphersIds = map CipherId <$> (choose (0, 200) >>= vector) arbitraryCompressionIDs :: Gen [Word8] arbitraryCompressionIDs = choose (0, 200) >>= vector @@ -363,21 +370,21 @@ clientHashSignatures <- arbitrary serverHashSignatures <- arbitrary let serverState = - def + defaultParamsServer { serverSupported = - def + defaultSupported { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures } - , serverShared = def{sharedCredentials = Credentials creds} + , serverShared = defaultShared{sharedCredentials = Credentials creds} } let clientState = (defaultParamsClient "" B.empty) { clientSupported = - def + defaultSupported { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg @@ -385,7 +392,7 @@ , supportedHashSignatures = clientHashSignatures } , clientShared = - def + defaultShared { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return () @@ -433,3 +440,8 @@ genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i + +-- Just for preventing warnings of GHC 9.10 +unsafeHead :: [a] -> a +unsafeHead [] = error "unsafeHead" +unsafeHead (x : _) = x diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -5,7 +5,6 @@ import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Default (def) import Data.IORef import Data.List import Data.Maybe @@ -99,7 +98,7 @@ where cgrps = supportedGroups $ clientSupported $ fst params sgrps = supportedGroups $ serverSupported $ snd params - hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest + hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest -------------------------------------------------------------- @@ -128,9 +127,9 @@ tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 ciphers = - [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_TLS13_AES128GCM_SHA256 + [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 + , cipher13_AES_128_GCM_SHA256 ] (clientParam, serverParam) <- generate $ @@ -232,7 +231,7 @@ handshake_ec (SG sigGroups) = do let versions = [TLS12] ciphers = - [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 + [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ] hashSignatures = [ (HashSHA256, SignatureECDSA) @@ -285,15 +284,15 @@ arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers where otherCiphers = - [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128GCM_SHA256 + [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 ] handshake_cert_fallback_cipher :: OC -> IO () handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do let clientVersions = [TLS12] serverVersions = [TLS12] - commonCiphers = [cipher_ECDHE_RSA_AES128GCM_SHA256] + commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] chainRef <- newIORef Nothing (clientParam, serverParam) <- @@ -341,9 +340,9 @@ tls13 <- generate arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = - [ cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_ECDSA_AES128GCM_SHA256 - , cipher_TLS13_AES128GCM_SHA256 + [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 + , cipher13_AES_128_GCM_SHA256 ] commonHS = [ (HashSHA256, SignatureRSA) @@ -673,13 +672,13 @@ handshake13_full :: CSP13 -> IO () handshake13_full (CSP13 (cli, srv)) = do let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params = @@ -691,13 +690,13 @@ handshake13_hrr :: CSP13 -> IO () handshake13_hrr (CSP13 (cli, srv)) = do let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params = @@ -709,13 +708,13 @@ handshake13_psk :: CSP13 -> IO () handshake13_psk (CSP13 (cli, srv)) = do let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = @@ -740,13 +739,13 @@ handshake13_psk_ticket :: CSP13 -> IO () handshake13_psk_ticket (CSP13 (cli, srv)) = do let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = @@ -772,16 +771,16 @@ handshake13_psk_fallback :: CSP13 -> IO () handshake13_psk_fallback (CSP13 (cli, srv)) = do let cliSupported = - def + defaultSupported { supportedCiphers = - [ cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES128CCM_SHA256 + [ cipher13_AES_128_GCM_SHA256 + , cipher13_AES_128_CCM_SHA256 ] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } params0 = @@ -804,8 +803,8 @@ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params srv2' = srv2{serverSupported = svrSupported'} svrSupported' = - def - { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256] } @@ -814,22 +813,22 @@ handshake13_0rtt :: CSP13 -> IO () handshake13_0rtt (CSP13 (cli, srv)) = do let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519] } cliHooks = - def + defaultClientHooks { onSuggestALPN = return $ Just ["h2"] } svrHooks = - def - { onALPNClientSuggest = Just (return . head) + defaultServerHooks + { onALPNClientSuggest = Just (return . unsafeHead) } params0 = ( cli @@ -867,13 +866,13 @@ handshake13_0rtt_fallback (CSP13 (cli, srv)) = do group0 <- generate $ elements [P256, X25519] let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [P256, X25519] } svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group0] } params = @@ -901,8 +900,8 @@ group1 <- generate $ elements [P256, X25519] let (pc, ps) = setPairParamsSessionResuming sessionParams params0 svrSupported1 = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1] } params1 = diff --git a/test/Run.hs b/test/Run.hs --- a/test/Run.hs +++ b/test/Run.hs @@ -21,7 +21,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import Data.Default (def) import Data.IORef import Network.TLS import System.Timeout @@ -273,8 +272,8 @@ logging pre = if debug then - def + defaultLogging { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } - else def + else defaultLogging 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.5 +version: 2.1.6 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -50,6 +50,7 @@ Network.TLS.Crypto.IES Network.TLS.Crypto.Types Network.TLS.ErrT + Network.TLS.Error Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Certificate @@ -77,6 +78,7 @@ Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13 + Network.TLS.HashAndSignature Network.TLS.Hooks Network.TLS.IO Network.TLS.Imports @@ -102,8 +104,12 @@ Network.TLS.Receiving Network.TLS.Util Network.TLS.Util.ASN1 - Network.TLS.Util.Serialization Network.TLS.Types + Network.TLS.Types.Cipher + Network.TLS.Types.Secret + Network.TLS.Types.Session + Network.TLS.Types.Version + Network.TLS.Util.Serialization Network.TLS.Wire Network.TLS.X509 @@ -159,7 +165,6 @@ crypton, crypton-x509, crypton-x509-validation, - data-default, hourglass, hspec, serialise, @@ -184,7 +189,6 @@ crypton, crypton-x509-store, crypton-x509-system, - data-default, network, network-run, tls @@ -212,7 +216,6 @@ crypton, crypton-x509-store, crypton-x509-system, - data-default, network, network-run, tls diff --git a/util/Client.hs b/util/Client.hs --- a/util/Client.hs +++ b/util/Client.hs @@ -10,6 +10,8 @@ import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Lazy.Char8 as CL8 +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Network.Socket import Network.TLS @@ -18,18 +20,18 @@ data Aux = Aux { auxAuthority :: HostName , auxPort :: ServiceName - , auxDebug :: String -> IO () + , auxDebugPrint :: String -> IO () , auxShow :: ByteString -> IO () , auxReadResumptionData :: IO [(SessionID, SessionData)] } -type Cli = Aux -> [ByteString] -> Context -> IO () +type Cli = Aux -> NonEmpty ByteString -> Context -> IO () clientHTTP11 :: Cli clientHTTP11 aux@Aux{..} paths ctx = do sendData ctx $ "GET " - <> CL8.fromStrict (head paths) + <> CL8.fromStrict (NE.head paths) <> " HTTP/1.1\r\n" <> "Host: " <> CL8.pack auxAuthority diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -3,11 +3,9 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Common ( - printCiphers, printDHParams, printGroups, readNumber, - readCiphers, readDHParams, readGroups, getCertificateStore, @@ -17,13 +15,10 @@ printHandshakeInfo, ) where -import Crypto.System.CPU import Data.Char (isDigit) import Data.X509.CertificateStore import Network.TLS hiding (HostName) -import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE -import Numeric (showHex) import System.Exit import System.X509 @@ -38,13 +33,6 @@ , ("ffdhe8192", ffdhe8192) ] -namedCiphersuites :: [(String, [CipherID])] -namedCiphersuites = - [ ("all", map cipherID ciphersuite_all) - , ("default", map cipherID ciphersuite_default) - , ("strong", map cipherID ciphersuite_strong) - ] - namedGroups :: [(String, Group)] namedGroups = [ ("ffdhe2048", FFDHE2048) @@ -64,12 +52,6 @@ | all isDigit s = Just $ read s | otherwise = Nothing -readCiphers :: String -> Maybe [CipherID] -readCiphers s = - case lookup s namedCiphersuites of - Nothing -> (: []) `fmap` readNumber s - just -> just - readDHParams :: String -> IO (Maybe DHParams) readDHParams s = case lookup s namedDHParams of @@ -81,34 +63,6 @@ Nothing -> [] Just gs -> gs -printCiphers :: IO () -printCiphers = do - putStrLn "Supported ciphers" - putStrLn "=====================================" - forM_ ciphersuite_all_det $ \c -> - putStrLn - ( pad 50 (cipherName c) - ++ " = " - ++ pad 5 (show $ cipherID c) - ++ " 0x" - ++ showHex (cipherID c) "" - ) - putStrLn "" - putStrLn "Ciphersuites" - putStrLn "=====================================" - forM_ namedCiphersuites $ \(name, _) -> putStrLn name - putStrLn "" - putStrLn - ("Using crypton-" ++ VERSION_crypton ++ " with CPU support for: " ++ cpuSupport) - where - pad n s - | length s < n = s ++ replicate (n - length s) ' ' - | otherwise = s - - cpuSupport - | null processorOptions = "(nothing)" - | otherwise = intercalate ", " (map show processorOptions) - printDHParams :: IO () printDHParams = do putStrLn "DH Parameters" @@ -125,9 +79,9 @@ split :: Char -> String -> [String] split _ "" = [] split c s = case break (c ==) s of - ("", r) -> split c (tail r) + ("", _ : rs) -> split c rs (s', "") -> [s'] - (s', r) -> s' : split c (tail r) + (s', _ : rs) -> s' : split c rs getCertificateStore :: [FilePath] -> IO CertificateStore getCertificateStore [] = getSystemCertificateStore diff --git a/util/Server.hs b/util/Server.hs --- a/util/Server.hs +++ b/util/Server.hs @@ -3,6 +3,7 @@ module Server where import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.IORef import Network.TLS @@ -14,13 +15,18 @@ server ctx showRequest = do recvRequest ctx showRequest sendData ctx $ - "HTTP/1.1 200 OK\r\n" - <> "Context-Type: text/html\r\n" - <> "Content-Length: " - <> BL8.pack (show (BL8.length body)) - <> "\r\n" - <> "\r\n" - <> body + -- "<>" 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 where body = "<Hello world!" @@ -31,6 +37,9 @@ where loop getLine = do bs <- getLine + when ("GET /keyupdate" `BS.isPrefixOf` bs) $ do + r <- updateKey ctx TwoWay + putStrLn $ "Updating key..." ++ if r then "OK" else "NG" when (bs /= "") $ do when showRequest $ do BS.putStr bs @@ -45,11 +54,11 @@ getline :: IORef ByteString -> IO ByteString getline ref = do bs0 <- readIORef ref - case BS.breakSubstring "\r\n" bs0 of + case BS.breakSubstring "\n" bs0 of (_, "") -> do bs1 <- recvData ctx writeIORef ref (bs0 <> bs1) getline ref (bs1, bs2) -> do - writeIORef ref $ BS.drop 2 bs2 - return bs1 + writeIORef ref $ BS.drop 1 bs2 + return $ BS.dropWhileEnd (== 0x0d) bs1 diff --git a/util/tls-client.hs b/util/tls-client.hs --- a/util/tls-client.hs +++ b/util/tls-client.hs @@ -1,19 +1,21 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main where import Control.Concurrent -import qualified Control.Exception as E import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8 -import Data.Default (def) import Data.IORef +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.X509.CertificateStore import Network.Run.TCP import Network.Socket import Network.TLS hiding (is0RTTPossible) +import Network.TLS.Internal (makeCipherShowPretty) import System.Console.GetOpt import System.Environment import System.Exit @@ -44,13 +46,13 @@ { optDebugLog = False , optShow = False , optKeyLogFile = Nothing - , optGroups = supportedGroups def + , optGroups = supportedGroups defaultSupported , optValidate = False , optVerNego = False , optResumption = False , opt0RTT = False , optRetry = False - , optVersions = supportedVersions def + , optVersions = supportedVersions defaultSupported , optALPN = "http/1.1" } @@ -137,7 +139,7 @@ [] -> showUsageAndExit usage _ : [] -> showUsageAndExit usage h : p : [] -> return (h, p, ["/"]) - h : p : ps -> return (h, p, C8.pack <$> ps) + h : p : ps -> return (h, p, C8.pack <$> NE.fromList ps) when (null optGroups) $ do putStrLn "Error: unsupported groups" exitFailure @@ -152,7 +154,7 @@ Aux { auxAuthority = host , auxPort = port - , auxDebug = debug + , auxDebugPrint = debug , auxShow = showContent , auxReadResumptionData = readIORef ref } @@ -162,12 +164,14 @@ client | optALPN == "dot" = clientDNS | otherwise = clientHTTP11 + makeCipherShowPretty runClient opts client cparams aux paths -runClient :: Options -> Cli -> ClientParams -> Aux -> [ByteString] -> IO () +runClient + :: Options -> Cli -> ClientParams -> Aux -> NonEmpty ByteString -> IO () runClient opts@Options{..} client cparams aux@Aux{..} paths = do - auxDebug "------------------------" - (info1, msd) <- runTLS cparams aux $ \ctx -> do + auxDebugPrint "------------------------" + (info1, msd) <- runTLS opts cparams aux $ \ctx -> do i1 <- getInfo ctx when optDebugLog $ printHandshakeInfo i1 client aux paths ctx @@ -233,13 +237,13 @@ -> Cli -> ClientParams -> Aux - -> [ByteString] + -> NonEmpty ByteString -> IO Information -runClient2 Options{..} client cparams aux@Aux{..} paths = do +runClient2 opts@Options{..} client cparams aux@Aux{..} paths = do threadDelay 100000 - auxDebug "<<<< next connection >>>>" - auxDebug "------------------------" - runTLS cparams aux $ \ctx -> do + auxDebugPrint "<<<< next connection >>>>" + auxDebugPrint "------------------------" + runTLS opts cparams aux $ \ctx -> do if opt0RTT then do void $ client aux paths ctx @@ -253,15 +257,25 @@ return i runTLS - :: ClientParams + :: Options + -> ClientParams -> Aux -> (Context -> IO a) -> IO a -runTLS cparams Aux{..} action = +runTLS Options{..} cparams Aux{..} action = runTCPClient auxAuthority auxPort $ \sock -> do - E.bracket (contextNew sock cparams) bye $ \ctx -> do - handshake ctx - action ctx + ctx <- contextNew sock cparams + when optDebugLog $ + contextHookSetLogging + ctx + defaultLogging + { loggingPacketSent = putStrLn . (">> " ++) + , loggingPacketRecv = putStrLn . ("<< " ++) + } + handshake ctx + r <- action ctx + bye ctx + return r modifyClientParams :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams @@ -291,7 +305,7 @@ | optRetry = FFDHE8192 : optGroups | otherwise = optGroups shared = - def + defaultShared { sharedSessionManager = sm , sharedCAStore = case mstore of Just store -> store @@ -299,22 +313,22 @@ , sharedValidationCache = validateCache } supported = - def + defaultSupported { supportedVersions = optVersions , supportedGroups = groups } hooks = - def + defaultClientHooks { onSuggestALPN = return $ Just [C8.pack optALPN] } validateCache - | isJust mstore = def + | isJust mstore = sharedValidationCache defaultShared | otherwise = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) debug = - def + defaultDebugParams { debugKeyLogger = getLogger optKeyLogFile } diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -5,14 +5,13 @@ module Main where -import qualified Control.Exception as E import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as C8 -import Data.Default (def) import Data.IORef import qualified Data.Map.Strict as M import Network.Run.TCP import Network.TLS +import Network.TLS.Internal import System.Console.GetOpt import System.Environment (getArgs) import System.Exit @@ -38,8 +37,7 @@ { optDebugLog = False , optShow = False , optKeyLogFile = Nothing - , -- excluding FFDHE8192 for retry - optGroups = [X25519, X448, P256, P521] + , optGroups = supportedGroups defaultSupported , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem" } @@ -108,14 +106,23 @@ Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile let keyLog = getLogger optKeyLogFile creds = Credentials [cred] + makeCipherShowPretty runTCPServer (Just host) port $ \sock -> do let sparams = getServerParams creds optGroups smgr keyLog - E.bracket (contextNew sock sparams) bye $ \ctx -> do - handshake ctx - when (optDebugLog || optShow) $ putStrLn "------------------------" - when optDebugLog $ - getInfo ctx >>= printHandshakeInfo - server ctx optShow + ctx <- contextNew sock sparams + when optDebugLog $ + contextHookSetLogging + ctx + defaultLogging + { loggingPacketSent = putStrLn . ("<< " ++) + , loggingPacketRecv = putStrLn . (">> " ++) + } + when (optDebugLog || optShow) $ putStrLn "------------------------" + handshake ctx + when optDebugLog $ + getInfo ctx >>= printHandshakeInfo + server ctx optShow + bye ctx getServerParams :: Credentials @@ -124,7 +131,7 @@ -> (String -> IO ()) -> ServerParams getServerParams creds groups sm keyLog = - def + defaultParamsServer { serverSupported = supported , serverShared = shared , serverHooks = hooks @@ -133,16 +140,16 @@ } where shared = - def + defaultShared { sharedCredentials = creds , sharedSessionManager = sm } supported = - def + defaultSupported { supportedGroups = groups } - hooks = def{onALPNClientSuggest = Just chooseALPN} - debug = def{debugKeyLogger = keyLog} + hooks = defaultServerHooks{onALPNClientSuggest = Just chooseALPN} + debug = defaultDebugParams{debugKeyLogger = keyLog} chooseALPN :: [ByteString] -> IO ByteString chooseALPN protos