tls 2.0.2 → 2.4.3
raw patch · 102 files changed
Files
- Benchmarks/Benchmarks.hs +187/−0
- CHANGELOG.md +180/−1
- Network/TLS.hs +158/−20
- Network/TLS/Backend.hs +16/−3
- Network/TLS/Cipher.hs +17/−75
- Network/TLS/Compression.hs +2/−1
- Network/TLS/Context.hs +34/−15
- Network/TLS/Context/Internal.hs +126/−48
- Network/TLS/Core.hs +202/−147
- Network/TLS/Credentials.hs +4/−3
- Network/TLS/Crypto.hs +52/−31
- Network/TLS/Crypto/DH.hs +7/−5
- Network/TLS/Crypto/IES.hs +373/−124
- Network/TLS/Crypto/Types.hs +60/−2
- Network/TLS/Error.hs +198/−0
- Network/TLS/Extension.hs +1173/−625
- Network/TLS/Extension.hs-boot +22/−0
- Network/TLS/Extra/Cipher.hs +544/−321
- Network/TLS/Extra/CipherCBC.hs +201/−0
- Network/TLS/Handshake.hs +4/−5
- Network/TLS/Handshake/Certificate.hs +22/−1
- Network/TLS/Handshake/Client.hs +69/−45
- Network/TLS/Handshake/Client/ClientHello.hs +426/−132
- Network/TLS/Handshake/Client/Common.hs +17/−4
- Network/TLS/Handshake/Client/ServerHello.hs +167/−64
- Network/TLS/Handshake/Client/TLS12.hs +38/−32
- Network/TLS/Handshake/Client/TLS13.hs +82/−49
- Network/TLS/Handshake/Common.hs +184/−54
- Network/TLS/Handshake/Common13.hs +245/−146
- Network/TLS/Handshake/Key.hs +17/−14
- Network/TLS/Handshake/Process.hs +0/−35
- Network/TLS/Handshake/Random.hs +20/−47
- Network/TLS/Handshake/Server.hs +41/−43
- Network/TLS/Handshake/Server/ClientHello.hs +221/−35
- Network/TLS/Handshake/Server/ClientHello12.hs +43/−52
- Network/TLS/Handshake/Server/ClientHello13.hs +164/−71
- Network/TLS/Handshake/Server/Common.hs +105/−42
- Network/TLS/Handshake/Server/ServerHello12.hs +116/−111
- Network/TLS/Handshake/Server/ServerHello13.hs +199/−143
- Network/TLS/Handshake/Server/TLS12.hs +35/−23
- Network/TLS/Handshake/Server/TLS13.hs +202/−51
- Network/TLS/Handshake/State.hs +134/−129
- Network/TLS/Handshake/State13.hs +5/−58
- Network/TLS/Handshake/TranscriptHash.hs +131/−0
- Network/TLS/HashAndSignature.hs +181/−0
- Network/TLS/Hooks.hs +6/−4
- Network/TLS/IO.hs +99/−68
- Network/TLS/IO/Decode.hs +109/−0
- Network/TLS/IO/Encode.hs +148/−0
- Network/TLS/Imports.hs +4/−8
- Network/TLS/Internal.hs +19/−6
- Network/TLS/KeySchedule.hs +13/−8
- Network/TLS/MAC.hs +35/−31
- Network/TLS/Packet.hs +241/−202
- Network/TLS/Packet13.hs +119/−61
- Network/TLS/Parameters.hs +459/−195
- Network/TLS/PostHandshake.hs +13/−12
- Network/TLS/QUIC.hs +18/−11
- Network/TLS/Receiving.hs +0/−90
- Network/TLS/Record.hs +5/−6
- Network/TLS/Record/Decrypt.hs +207/−0
- Network/TLS/Record/Disengage.hs +0/−193
- Network/TLS/Record/Encrypt.hs +131/−0
- Network/TLS/Record/Engage.hs +0/−139
- Network/TLS/Record/Layer.hs +2/−2
- Network/TLS/Record/Reading.hs +0/−103
- Network/TLS/Record/Recv.hs +112/−0
- Network/TLS/Record/Send.hs +61/−0
- Network/TLS/Record/State.hs +5/−4
- Network/TLS/Record/Types.hs +7/−29
- Network/TLS/Record/Writing.hs +0/−59
- Network/TLS/Sending.hs +0/−124
- Network/TLS/Session.hs +8/−6
- Network/TLS/State.hs +91/−73
- Network/TLS/Struct.hs +172/−591
- Network/TLS/Struct13.hs +39/−16
- Network/TLS/Types.hs +40/−155
- Network/TLS/Types/Cipher.hs +130/−0
- Network/TLS/Types/Secret.hs +62/−0
- Network/TLS/Types/Session.hs +73/−0
- Network/TLS/Types/Version.hs +40/−0
- Network/TLS/Util.hs +33/−19
- Network/TLS/Util/ASN1.hs +1/−0
- Network/TLS/Wire.hs +7/−2
- Network/TLS/X509.hs +22/−0
- test/Arbitrary.hs +63/−44
- test/Certificate.hs +1/−0
- test/CiphersSpec.hs +5/−3
- test/ECHSpec.hs +446/−0
- test/HandshakeSpec.hs +132/−61
- test/PubKey.hs +1/−0
- test/Run.hs +117/−3
- test/Session.hs +2/−2
- tls.cabal +134/−74
- util/Client.hs +61/−0
- util/Common.hs +61/−98
- util/HexDump.hs +0/−96
- util/Server.hs +92/−0
- util/client.hs +0/−515
- util/server.hs +0/−492
- util/tls-client.hs +465/−0
- util/tls-server.hs +270/−0
+ Benchmarks/Benchmarks.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns #-}++module Main where++import Certificate+import Control.Concurrent.Chan+import Data.Default (def)+import Data.IORef+import Data.X509+import Data.X509.Validation+import Test.Tasty.Bench+import Network.TLS+import Network.TLS.Extra.Cipher+import Session+import Run+import PubKey++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++blockCipher :: Cipher+blockCipher =+ Cipher+ { cipherID = 0xff12+ , cipherName = "rsa-id-const"+ , cipherBulk =+ Bulk+ { bulkName = "id"+ , bulkKeySize = 16+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF $ \_ _ _ m -> (m, B.empty)+ }+ , cipherHash = MD5+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Nothing+ }++getParams :: Version -> Cipher -> (ClientParams, ServerParams)+getParams connectVer cipher = (cParams, sParams)+ where+ sParams =+ def+ { serverSupported = supported+ , serverShared =+ def+ { sharedCredentials =+ Credentials+ [(CertificateChain [simpleX509 $ PubKeyRSA pubKey], PrivKeyRSA privKey)]+ }+ }+ cParams =+ (defaultParamsClient "" B.empty)+ { clientSupported = supported+ , clientShared =+ def+ { sharedValidationCache =+ ValidationCache+ { cacheAdd = \_ _ _ -> return ()+ , cacheQuery = \_ _ _ -> return ValidationCachePass+ }+ }+ }+ supported =+ def+ { supportedCiphers = [cipher]+ , supportedVersions = [connectVer]+ , supportedGroups = [X25519, FFDHE2048]+ }+ (pubKey, privKey) = getGlobalRSAPair++runTLSPipe+ :: (ClientParams, ServerParams)+ -> (Context -> Chan b -> IO ())+ -> (Chan a -> Context -> IO ())+ -> a+ -> IO b+runTLSPipe params tlsServer tlsClient d = do+ withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do+ writeStart d+ readResult++runTLSPipeSimple+ :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString+runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient+ where+ tlsServer ctx queue = do+ handshake ctx+ d <- recvData ctx+ writeChan queue d+ bye ctx+ tlsClient queue ctx = do+ handshake ctx+ d <- readChan queue+ sendData ctx (L.fromChunks [d])+ byeBye ctx++benchConnection+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d++benchResumption+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchResumption params !d name = env initializeSession runResumption+ where+ initializeSession = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ params1 = setPairParamsSessionManagers sessionManagers params+ _ <- runTLSPipeSimple params1 d++ Just sessionParams <- readClientSessionRef sessionRefs+ let params2 = setPairParamsSessionResuming sessionParams params1+ newIORef params2++ runResumption paramsRef = bench name . nfIO $ do+ params2 <- readIORef paramsRef+ runTLSPipeSimple params2 d++benchResumption13+ :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchResumption13 params !d name = env initializeSession runResumption+ where+ initializeSession = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ params1 = setPairParamsSessionManagers sessionManagers params+ _ <- runTLSPipeSimple params1 d+ newIORef (params1, sessionRefs)++ -- with TLS13 the sessionId is constantly changing so we must update+ -- our parameters at each iteration unfortunately+ runResumption paramsRef = bench name . nfIO $ do+ (params1, sessionRefs) <- readIORef paramsRef+ Just sessionParams <- readClientSessionRef sessionRefs+ let params2 = setPairParamsSessionResuming sessionParams params1+ runTLSPipeSimple params2 d++benchCiphers :: String -> Version -> B.ByteString -> [Cipher] -> Benchmark+benchCiphers name connectVer d = bgroup name . map doBench+ where+ doBench cipher =+ benchResumption13 (getParams connectVer cipher) d (cipherName cipher)++main :: IO ()+main =+ defaultMain+ [ bgroup+ "connection"+ -- not sure the number actually make sense for anything. improve ..+ [ benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes"+ ]+ , bgroup+ "resumption"+ [ benchResumption (getParams TLS12 blockCipher) small "TLS12-256 bytes"+ ]+ , -- Here we try to measure TLS12 and TLS13 performance with AEAD ciphers.+ -- Resumption and a larger message can be a demonstration of the symmetric+ -- crypto but for TLS13 this does not work so well because of dhe_psk.+ benchCiphers+ "TLS12"+ TLS12+ large+ [ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+ , cipher_DHE_RSA_WITH_AES_256_GCM_SHA384+ , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+ , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ , cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+ , cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256+ ]+ , benchCiphers+ "TLS13"+ TLS13+ large+ [ 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+ ]+ ]+ where+ small = B.replicate 256 0+ large = B.replicate 102400 0
CHANGELOG.md view
@@ -1,3 +1,182 @@+# Change log for "tls"++## Version 2.4.3++* A server checks clientAuth of ExtendedKeyUsage in a client+ certificate on client authentication.++## Version 2.4.2++* The `Network.TLS.Extra.CipherCBC` module is added.+ [#526](https://github.com/haskell-tls/hs-tls/pull/526)++## Version 2.4.1++* Ensure same `supported_groups` before/after HRR.+* New `clientWantTicket` parameter makes it possible to opt-out of soliciting+ session tickets from servers.++## Version 2.4.0++* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic".++## Version 2.3.1 (deprecated)++* Using ScrubbedBytes for secrets.+* Key echange with ML-KEM.+ [#517](https://github.com/haskell-tls/hs-tls/pull/517)+* Expose get certificate chain function+ [#520](https://github.com/haskell-tls/hs-tls/pull/520)++## Version 2.3.0++* Using "ram" instead of "memory".++## Version 2.2.2++* A new architecture to calculate receiver's transcript hash with wire+ format.+ [#515](https://github.com/haskell-tls/hs-tls/pull/515)+* Enabling compressed certificate on the client side again.++## Version 2.2.1++* Disabling compressed certificate on the client side.+ [#514](https://github.com/haskell-tls/hs-tls/issues/514)++## Version 2.2.0++* Using crypton-asn1-* and time-hourglass.+ [#512](https://github.com/haskell-tls/hs-tls/pull/512)+* Major version up due to re-exports.++## Version 2.1.14++* Supporting P384 and P521 curves.+ [#511](https://github.com/haskell-tls/hs-tls/pull/511)+* Fixing some bugs of `tls-client`.++## Version 2.1.13++* Don't contain early_data if serverEarlyDataSize is 0.+ [#510](https://github.com/haskell-tls/hs-tls/pull/510)++## Version 2.1.12++* Restore benchmarks.+ [#509](https://github.com/haskell-tls/hs-tls/pull/509)+* Supporting random 1.2.+ [#508](https://github.com/haskell-tls/hs-tls/pull/508)+* Add --trusted-anchor cli option to tls-client.+ [#505](https://github.com/haskell-tls/hs-tls/pull/505)++## Version 2.1.11++* Removing OVERLAPS instances.++## Version 2.1.10++* Supporting the SSLKEYLOGFILE environment variable.+ [#499](https://github.com/haskell-tls/hs-tls/pull/499)++## Version 2.1.9++* Providing ECH(Encrypted Client Hello). See `sharedECHConfigList`,+ `clientUseECH` and `serverECHKey`. Note that the `ech-gen` command,+ `loadECHConfigList` and `loadECHSecretKeys` are provided by the+ `ech-config` package.++## Version 2.1.8++* Moving `Limit` to `Shared` to maintain backward compatibility+ of `TLSParams` class.+* Deprecating 2.1.7.++## Version 2.1.7++* Introducing `Limit` parameter.+* Implementing "Record Size Limit Extension for TLS" (RFC8449).+ Set `limitRecordSize` use it.+* Implementing "TLS Certificate Compression" (RFC 8879).+ This feature is automatically used if the peer supports it.+* More tests with `tlsfuzzer` especially for client authentication+ and 0-RTT.+* Implementing a utility function, `validateClientCertificate`, for+ client authentication.+* Bug fix for echo back logic of Cookie extension.+* More pretty show for the internal `Handshake` structure for debugging.++## Version 2.1.6++* Testing with "tlsfuzzer" again. Now don't send an alert against 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.+* Restore a few DHE_RSA ciphers.+ [#493](https://github.com/haskell-tls/hs-tls/pull/493)++## Version 2.1.4++* Exporting defaultValidationCache.++## Version 2.1.3++* Remove `data-default` version constraint.+ [#492](https://github.com/haskell-tls/hs-tls/pull/492)+* Exporting default variables.+ [#448](https://github.com/haskell-tls/hs-tls/pull/488)++## Version 2.1.2++* Using data-default instead of data-default-class.++## Version 2.1.1++* `bye` directly calls `timeout recvHS13`, not spawning a thread for+ `timeout recvHS13`. So, `bye` can receive an exception if thrown.++## Version 2.1.0++* Breaking change: stop exporting constructors to maintain future+ compatibilities. Field names are still exported, and values can be updated+ with them using record syntax. Use `def` and `noSessionManager` as initial+ values.+* `onServerFinished` is added to `ClientHooks`.+* `clientWantSessionResumeList` is added to `ClientParams` to support+ multiple tickets for TLS 1.3.++## Version 2.0.6++* Setting `supportedCiphers` in `defaultSupported` to `ciphersuite_default`.+ So, users don't have to override this value anymore by exporting+ `Network.TLS.Extra.Cipher`.+ [#471](https://github.com/haskell-tls/hs-tls/pull/471)+* `ciphersuite_default` is the same as `ciphersuite_strong`.+ So, the duplicated definition is removed.+* Add missing modules for util/tls-client and util/tls-server.++## Version 2.0.5++* Fixing handshake13_0rtt_fallback+* Client checks if the group of PSK is contained in Supported_Groups.+* HRR is not allowed for 0-RTT.++## Version 2.0.4++* More fix for 0-RTT when application data is available while receiving CF.+* New util/tls-client and util/tls-server.++## Version 2.0.3++* Fixing a bug where `timeout` in `bye` does not work.+* util/client -> util/tls-client+* util/server -> util/tls-server+ ## Version 2.0.2 * Client checks sessionMaxEarlyDataSize to decide 0-RTT@@ -193,7 +372,7 @@ API CHANGES: - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce`- function to accomodate resumption scenarios with 0-RTT data. The function is+ function to accommodate resumption scenarios with 0-RTT data. The function is called only on the server side. - Data type `SessionData` is extended with four new fields for TLS version 1.3. `SessionManager` implementations that serializes/deserializes `SessionData`
Network/TLS.hs view
@@ -10,6 +10,14 @@ -- Currently implement the TLS1.2 and TLS 1.3 -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions.+--+-- The typical usage is:+--+-- > socket <- ...+-- > ctx <- contextNew socket <params>+-- > handshake ctx+-- > ... (using recvData and sendData)+-- > bye module Network.TLS ( -- * Basic APIs Context,@@ -30,26 +38,109 @@ -- intentionally hide the internal methods even haddock warns. TLSParams,- ClientParams (..),++ -- ** Client parameters+ ClientParams, defaultParamsClient,- ServerParams (..),+ clientServerIdentification,+ clientUseServerNameIndication,+ clientWantSessionResume,+ clientWantSessionResumeList,+ clientWantTicket,+ clientShared,+ clientHooks,+ clientSupported,+ clientDebug,+ clientUseEarlyData,+ clientUseECH, + -- ** Server parameters+ ServerParams,+ defaultParamsServer,+ serverWantClientCert,+ serverCACertificates,+ serverDHEParams,+ serverHooks,+ serverShared,+ serverSupported,+ serverDebug,+ serverEarlyDataSize,+ serverTicketLifetime,+ serverECHKey,+ -- ** Shared- Shared (..),+ Shared,+ defaultShared,+ sharedCredentials,+ sharedSessionManager,+ sharedCAStore,+ sharedValidationCache,+ sharedHelloExtensions,+ sharedECHConfigList,+ sharedLimit, - -- ** Hooks- ClientHooks (..),+ -- ** Client hooks+ ClientHooks,+ defaultClientHooks, OnCertificateRequest,+ onCertificateRequest, OnServerCertificate,- ServerHooks (..),- Measurement (..),+ onServerCertificate,+ onSuggestALPN,+ onCustomFFDHEGroup,+ onServerFinished,+ onSelectKeyShareGroups, + -- ** Server hooks+ ServerHooks,+ defaultServerHooks,+ onClientCertificate,+ validateClientCertificate,+ onUnverifiedClientCert,+ onCipherChoosing,+ onServerNameIndication,+ onNewHandshake,+ onALPNClientSuggest,+ onEncryptedExtensionsCreating,+ onSelectKeyShare,+ Measurement,+ nbHandshakes,+ bytesReceived,+ bytesSent,+ -- ** Supported- Supported (..),+ Supported,+ defaultSupported,+ supportedVersions,+ supportedCiphers,+ supportedCompressions,+ supportedHashSignatures,+ supportedSecureRenegotiation,+ supportedClientInitiatedRenegotiation,+ supportedExtendedMainSecret,+ supportedSession,+ supportedFallbackScsv,+ supportedEmptyPacket,+ supportedGroups,+ supportedGroupsTLS13, -- ** Debug parameters- DebugParams (..),+ DebugParams,+ defaultDebugParams,+ debugSeed,+ debugPrintSeed,+ debugVersionForced,+ debugKeyLogger,+ defaultKeyLogger,+ debugError,+ debugTraceKey, + -- ** Limit parameters+ Limit,+ defaultLimit,+ limitHandshakeFragment,+ limitRecordSize,+ -- * Shared parameters -- ** Credentials@@ -61,17 +152,36 @@ credentialLoadX509ChainFromMemory, -- ** Session manager- SessionManager (..),+ SessionManager, noSessionManager,+ sessionResume,+ sessionResumeOnlyOnce,+ sessionEstablish,+ sessionInvalidate,+ sessionUseTicket, SessionID, SessionIDorTicket, Ticket,- SessionData (..),++ -- ** Session data+ SessionData,+ sessionVersion,+ sessionCipher,+ sessionCompression,+ sessionClientSNI,+ sessionSecret,+ sessionGroup,+ sessionTicketInfo,+ sessionALPN,+ sessionMaxEarlyDataSize,+ sessionFlags, SessionFlag (..), TLS13TicketInfo,+ is0RTTPossible, -- ** Validation Cache ValidationCache (..),+ defaultValidationCache, ValidationCacheQueryCallback, ValidationCacheAddCallback, ValidationCacheResult (..),@@ -98,6 +208,7 @@ CertificateUsage (..), CertificateRejectReason (..), CertificateType (..),+ CertificateChain (..), HostName, MaxFragmentEnum (..), @@ -109,14 +220,27 @@ contextClose, -- ** Information gathering- Information (..),+ Information, contextGetInformation,+ infoVersion,+ infoCipher,+ infoCompression,+ infoMainSecret,+ infoExtendedMainSecret,+ infoClientRandom,+ infoServerRandom,+ infoSupportedGroup,+ infoTLS12Resumption,+ infoTLS13HandshakeMode,+ infoIsEarlyDataAccepted,+ infoIsECHAccepted, ClientRandom, ServerRandom, unClientRandom, unServerRandom, HandshakeMode13 (..), getClientCertificateChain,+ getServerCertificateChain, -- ** Negotiated getNegotiatedProtocol,@@ -133,14 +257,24 @@ getPeerFinished, -- ** Modifying hooks in context- Hooks (..),+ Hooks,+ defaultHooks,+ hookRecvHandshake,+ hookRecvHandshake13,+ hookRecvCertificates,+ hookLogging, contextModifyHooks, Handshake, contextHookSetHandshakeRecv, Handshake13, contextHookSetHandshake13Recv, contextHookSetCertificateRecv,- Logging (..),+ Logging,+ defaultLogging,+ loggingPacketSent,+ loggingPacketRecv,+ loggingIOSent,+ loggingIORecv, Header (..), ProtocolType (..), contextHookSetLogging,@@ -173,8 +307,12 @@ Bytes, ValidationChecks (..), ValidationHooks (..),+ clientUseMaxFragmentLength, ) where +import Data.X509 (PrivKey (..), PubKey (..))+import Data.X509.Validation hiding (HostName, defaultHooks)+ import Network.TLS.Backend (Backend (..), HasBackend (..)) import Network.TLS.Cipher import Network.TLS.Compression (@@ -188,12 +326,13 @@ import Network.TLS.Crypto ( DHParams, DHPublic,- Group (..), KxError (..), supportedNamedGroups, )+import Network.TLS.Extension import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks+import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session@@ -217,12 +356,8 @@ import Network.TLS.Types import Network.TLS.X509 -import Data.ByteString as B-import Data.X509 (PrivKey (..), PubKey (..))-import Data.X509.Validation hiding (HostName)- {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-}-type Bytes = B.ByteString+type Bytes = ByteString -- | Getting certificates from a client, if any. -- Note that the certificates are not sent by a client@@ -231,6 +366,9 @@ -- both cases of full-negotiation and resumption. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain++getServerCertificateChain :: Context -> IO (Maybe CertificateChain)+getServerCertificateChain ctx = usingState_ ctx S.getServerCertificateChain -- $exceptions -- Since 1.8.0, this library only throws exceptions of type 'TLSException'.
Network/TLS/Backend.hs view
@@ -15,9 +15,10 @@ import qualified Data.ByteString as B import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network-import Network.TLS.Imports import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) +import Network.TLS.Imports+ -- | Connection IO backend data Backend = Backend { backendFlush :: IO ()@@ -43,7 +44,13 @@ instance HasBackend Network.Socket where initializeBackend _ = return ()- getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll+ getBackend sock =+ Backend+ { backendFlush = return ()+ , backendClose = Network.close sock+ , backendSend = Network.sendAll sock+ , backendRecv = recvAll+ } where recvAll n = B.concat <$> loop n where@@ -56,4 +63,10 @@ instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering- getBackend handle = Backend (hFlush handle) (hClose handle) (B.hPut handle) (B.hGet handle)+ getBackend handle =+ Backend+ { backendFlush = hFlush handle+ , backendClose = hClose handle+ , backendSend = B.hPut handle+ , backendRecv = B.hGet handle+ }
Network/TLS/Cipher.hs view
@@ -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
Network/TLS/Compression.hs view
@@ -18,6 +18,7 @@ ) where import Control.Arrow (first)+ import Network.TLS.Imports import Network.TLS.Types (CompressionID) @@ -50,7 +51,7 @@ (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression--- the function keeps the list of compression in order, to be able to find quickly the prefered+-- the function keeps the list of compression in order, to be able to find quickly the preferred -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l
Network/TLS/Context.hs view
@@ -58,6 +58,15 @@ TLS13State (..), getTLS13State, modifyTLS13State,+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef, ) where import Control.Concurrent.MVar@@ -83,24 +92,27 @@ import Network.TLS.Parameters import Network.TLS.PostHandshake ( postHandshakeAuthClientWith,- postHandshakeAuthServerWith, requestCertificateServer, ) import Network.TLS.RNG-import Network.TLS.Record.Reading+import Network.TLS.Record.Recv+import Network.TLS.Record.Send import Network.TLS.Record.State-import Network.TLS.Record.Writing import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13-import Network.TLS.Types (Role (..))+import Network.TLS.Types (+ Role (..),+ TranscriptHash (..),+ defaultRecordSizeLimit,+ ) import Network.TLS.X509 class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO ()- doHandshakeWith :: a -> Context -> Handshake -> IO ()+ doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () @@ -126,7 +138,7 @@ doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer- doPostHandshakeAuthWith = postHandshakeAuthServerWith+ doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified. contextNew@@ -163,9 +175,11 @@ hs <- newMVar Nothing recvActionsRef <- newIORef [] sendActionRef <- newIORef Nothing- crs <- newIORef [] locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State+ mylimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ peerlimref <- newRecordLimitRef $ Just defaultRecordSizeLimit+ hpkeref <- newIORef Nothing let roleParams = RoleParams { doHandshake_ = doHandshake params@@ -179,8 +193,10 @@ { ctxBackend = getBackend backend , ctxShared = shared , ctxSupported = supported+ , ctxDebug = debug , ctxTLSState = tlsstate- , ctxFragmentSize = Just 16384+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxTxRecordState = tx , ctxRxRecordState = rx , ctxHandshakeState = hs@@ -193,22 +209,21 @@ , ctxLocks = locks , ctxPendingRecvActions = recvActionsRef , ctxPendingSendAction = sendActionRef- , ctxCertRequests = crs- , ctxKeyLogger = debugKeyLogger debug , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp , ctxQUICMode = False , ctxTLS13State = st13ref+ , ctxHPKE = hpkeref } syncNoOp _ _ = return () recordLayer = RecordLayer- { recordEncode = encodeRecord+ { recordEncode12 = encodeRecord12 , recordEncode13 = encodeRecord13 , recordSendBytes = sendBytes- , recordRecv = recvRecord+ , recordRecv12 = recvRecord12 , recordRecv13 = recvRecord13 } @@ -252,7 +267,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).@@ -266,12 +285,12 @@ exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString) exporter ctx label context outlen = do- msecret <- usingState_ ctx getExporterSecret+ msecret <- usingState_ ctx getTLS13ExporterSecret mcipher <- failOnEitherError $ runRxRecordState ctx $ gets stCipher return $ case (msecret, mcipher) of (Just secret, Just cipher) -> let h = cipherHash cipher- secret' = deriveSecret h secret label ""+ secret' = deriveSecret h secret label $ TranscriptHash "" label' = "exporter" value' = hash h context key = hkdfExpandLabel h secret' label' value' outlen
Network/TLS/Context/Internal.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Network.TLS.Context.Internal (@@ -16,6 +15,7 @@ -- * Context object and accessor Context (..), Hooks (..),+ Limit (..), Established (..), PendingRecvAction (..), RecordLayer (..),@@ -57,8 +57,6 @@ restoreHState, getStateRNG, tls13orLater,- addCertRequest13,- getCertRequest13, decideRecordVersion, -- * Misc@@ -69,18 +67,35 @@ modifyTLS13State, CipherChoice (..), makeCipherChoice,++ -- * RecordLimit+ setMyRecordLimit,+ enableMyRecordLimit,+ getMyRecordLimit,+ checkMyRecordLimit,+ setPeerRecordLimit,+ enablePeerRecordLimit,+ getPeerRecordLimit,+ checkPeerRecordLimit,+ newRecordLimitRef,++ -- * ECH+ HPKEF,+ getTLS13HPKE,+ setTLS13HPKE, ) where import Control.Concurrent.MVar import Control.Exception (throwIO) import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.IORef import Data.Tuple import Network.TLS.Backend import Network.TLS.Cipher-import Network.TLS.Compression (Compression) import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Control@@ -97,30 +112,16 @@ import Network.TLS.Types import Network.TLS.Util --- | Information related to a running context, e.g. current cipher-data Information = Information- { infoVersion :: Version- , infoCipher :: Cipher- , infoCompression :: Compression- , infoMainSecret :: Maybe ByteString- , infoExtendedMainSecret :: Bool- , infoClientRandom :: Maybe ClientRandom- , infoServerRandom :: Maybe ServerRandom- , infoSupportedGroup :: Maybe Group- , infoTLS12Resumption :: Bool- , infoTLS13HandshakeMode :: Maybe HandshakeMode13- , infoIsEarlyDataAccepted :: Bool- }- deriving (Show, Eq)- -- | A TLS Context keep tls specific state, parameters and backend information.-data Context = forall a.+data Context+ = forall a. Monoid a => Context { ctxBackend :: Backend -- ^ return the backend object associated with this context , ctxSupported :: Supported , ctxShared :: Shared+ , ctxDebug :: DebugParams , ctxTLSState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool@@ -136,13 +137,11 @@ , ctxRoleParams :: RoleParams -- ^ hooks for this context , ctxLocks :: Locks- , ctxKeyLogger :: String -> IO () , ctxHooks :: IORef Hooks , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] , ctxPendingSendAction :: IORef (Maybe (Context -> IO ()))- , ctxCertRequests :: IORef [Handshake13] -- ^ pending post handshake authentication requests , -- QUIC ctxRecordLayer :: RecordLayer a@@ -151,13 +150,25 @@ , -- Misc ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability.- , ctxFragmentSize :: Maybe Int- -- ^ maximum size of plaintext fragments+ , ctxMyRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxPeerRecordLimit :: IORef RecordLimit+ -- ^ maximum size of plaintext fragments, val + 1 is used for TLS 1.3+ , ctxHPKE :: IORef (Maybe (HPKEF, Int)) } +type HPKEF = ByteString -> ByteString -> IO ByteString++data RecordLimit+ = NoRecordLimit -- for QUIC+ | RecordLimit+ Int -- effective+ (Maybe Int) -- pending+ deriving (Eq, Show)+ data RoleParams = RoleParams { doHandshake_ :: Context -> IO ()- , doHandshakeWith_ :: Context -> Handshake -> IO ()+ , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () }@@ -176,7 +187,7 @@ { cVersion :: Version , cCipher :: Cipher , cHash :: Hash- , cZero :: ByteString+ , cZero :: Secret } deriving (Show) @@ -184,7 +195,7 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher- zero = B.replicate (hashDigestSize h) 0+ zero = BA.replicate (hashDigestSize h) 0 data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client@@ -200,6 +211,7 @@ , tls13stClientExtensions :: [ExtensionRaw] -- client , tls13stChoice :: ~CipherChoice -- client , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client+ -- Actual session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] }@@ -238,11 +250,11 @@ {- FOURMOLU_DISABLE -} data RecordLayer a = RecordLayer { -- Writing.hs- recordEncode :: Context -> Record Plaintext -> IO (Either TLSError a)+ recordEncode12 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordEncode13 :: Context -> Record Plaintext -> IO (Either TLSError a) , recordSendBytes :: Context -> a -> IO () , -- Reading.hs- recordRecv :: Context -> Int -> IO (Either TLSError (Record Plaintext))+ recordRecv12 :: Context -> IO (Either TLSError (Record Plaintext)) , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext)) } {- FOURMOLU_ENABLE -}@@ -262,9 +274,12 @@ data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment. PendingRecvAction Bool (Handshake13 -> IO ())+ | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment.- PendingRecvActionHash Bool (ByteString -> Handshake13 -> IO ())+ PendingRecvActionHash+ Bool+ (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)@@ -285,7 +300,7 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx- let (ms, ems, cr, sr, hm13, grp) =+ let (ms, ems, cr, sr, hm13, grp, ech) = case hstate of Just st -> ( hstMainSecret st@@ -294,19 +309,33 @@ , hstServerRandom st , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing , hstSupportedGroup st+ , hstTLS13ECHAccepted st )- Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing)+ Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing, False) (cipher, comp) <- readMVar (ctxRxRecordState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False- tls12resumption <- usingState_ ctx isSessionResuming+ tls12resumption <- usingState_ ctx getTLS12SessionResuming case (ver, cipher) of (Just v, Just c) -> return $ Just $- Information v c comp ms ems cr sr grp tls12resumption hm13 accepted+ Information+ { infoVersion = v+ , infoCipher = c+ , infoCompression = comp+ , infoMainSecret = convert <$> ms+ , infoExtendedMainSecret = ems+ , infoClientRandom = cr+ , infoServerRandom = sr+ , infoSupportedGroup = grp+ , infoTLS12Resumption = tls12resumption+ , infoTLS13HandshakeMode = hm13+ , infoIsEarlyDataAccepted = accepted+ , infoIsECHAccepted = ech+ } _ -> return Nothing contextSend :: Context -> ByteString -> IO ()@@ -329,7 +358,7 @@ ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()-contextModifyHooks ctx = modifyIORef (ctxHooks ctx)+contextModifyHooks ctx = modifyIORef' (ctxHooks ctx) setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx)@@ -437,17 +466,66 @@ Left _ -> False Right v -> v >= TLS13 -addCertRequest13 :: Context -> Handshake13 -> IO ()-addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq :)+-------------------------------- -getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13)-getCertRequest13 ctx context = do- let ref = ctxCertRequests ctx- l <- readIORef ref- let (matched, others) = partition (\cr -> context == fromCertRequest13 cr) l- case matched of- [] -> return Nothing- (certReq : _) -> writeIORef ref others >> return (Just certReq)+setMyRecordLimit :: Context -> Maybe Int -> IO ()+setMyRecordLimit ctx msiz = modifyIORef' (ctxMyRecordLimit ctx) change where- fromCertRequest13 (CertRequest13 c _) = c- fromCertRequest13 _ = error "fromCertRequest13"+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enableMyRecordLimit :: Context -> IO ()+enableMyRecordLimit ctx = modifyIORef' (ctxMyRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getMyRecordLimit :: Context -> IO (Maybe Int)+getMyRecordLimit ctx = change <$> readIORef (ctxMyRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkMyRecordLimit :: Context -> IO Bool+checkMyRecordLimit ctx = chk <$> readIORef (ctxMyRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++--------------------------------++setPeerRecordLimit :: Context -> Maybe Int -> IO ()+setPeerRecordLimit ctx msiz = modifyIORef' (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit n _) = RecordLimit n msiz+ change x = x++enablePeerRecordLimit :: Context -> IO ()+enablePeerRecordLimit ctx = modifyIORef' (ctxPeerRecordLimit ctx) change+ where+ change (RecordLimit _ (Just n)) = RecordLimit n Nothing+ change x = x++getPeerRecordLimit :: Context -> IO (Maybe Int)+getPeerRecordLimit ctx = change <$> readIORef (ctxPeerRecordLimit ctx)+ where+ change NoRecordLimit = Nothing+ change (RecordLimit n _) = Just n++checkPeerRecordLimit :: Context -> IO Bool+checkPeerRecordLimit ctx = chk <$> readIORef (ctxPeerRecordLimit ctx)+ where+ chk NoRecordLimit = False+ chk (RecordLimit _ mx) = isJust mx++newRecordLimitRef :: Maybe Int -> IO (IORef RecordLimit)+newRecordLimitRef Nothing = newIORef NoRecordLimit+newRecordLimitRef (Just n) = newIORef $ RecordLimit n Nothing++--------------------------------++setTLS13HPKE :: Context -> HPKEF -> Int -> IO ()+setTLS13HPKE ctx func nenc = writeIORef (ctxHPKE ctx) $ Just (func, nenc)++getTLS13HPKE :: Context -> IO (Maybe (HPKEF, Int))+getTLS13HPKE ctx = readIORef $ ctxHPKE ctx
Network/TLS/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} @@ -27,7 +28,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@@ -35,18 +35,17 @@ import Data.IORef import System.Timeout -import Network.TLS.Cipher import Network.TLS.Context-import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13-import Network.TLS.Handshake.Process+import Network.TLS.Handshake.Server import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO-import Network.TLS.KeySchedule+import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.PostHandshake import Network.TLS.Session@@ -55,15 +54,14 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (- AnyTrafficSecret (..),- ApplicationSecret, HostName, Role (..), ) import Network.TLS.Util (catchException, mapChunks_) -- | Handshake for a new TLS connection--- This is to be called at the beginning of a connection, and during renegotiation+-- This is to be called at the beginning of a connection, and during renegotiation.+-- Don't use this function as the acquire resource of 'bracket'. handshake :: MonadIO m => Context -> m () handshake ctx = do handshake_ ctx@@ -74,7 +72,8 @@ sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx when (role == ClientRole && tls13 && sentClientCert) $ do rtt <- getRTT ctx- mdat <- timeout rtt $ recvData ctx+ -- This 'timeout' should work.+ mdat <- timeout rtt $ recvData13 ctx case mdat of Nothing -> return () Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat}@@ -85,13 +84,26 @@ getRTT :: Context -> IO Int getRTT ctx = do rtt <- tls13stRTT <$> getTLS13State ctx- return (fromIntegral rtt * rttFactor * 1000) -- ms to us+ let rtt' = max (fromIntegral rtt) 10+ return (rtt' * rttFactor * 1000) -- ms to us --- | notify the context that this side wants to close connection.--- this is important that it is called before closing the handle, otherwise+-- | Notify the context that this side wants to close connection.+-- This is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2).+-- This doesn't actually close the handle. ----- this doesn't actually close the handle+-- Proper usage is as follows:+--+-- > ctx <- contextNew <backend> <params>+-- > handshake ctx+-- > ...+-- > bye+--+-- The following code ensures nothing but is no harm.+--+-- > bracket (contextNew <backend> <params>) bye $ \ctx -> do+-- > handshake ctx+-- > ... bye :: MonadIO m => Context -> m () bye ctx = liftIO $ do eof <- ctxEOF ctx@@ -102,17 +114,20 @@ then do withWriteLock ctx $ sendCFifNecessary ctx -- receiving NewSessionTicket- recvNST <- tls13stRecvNST <$> getTLS13State ctx+ let chk = tls13stRecvNST <$> getTLS13State ctx+ recvNST <- chk unless recvNST $ do rtt <- getRTT ctx- void $ timeout rtt $ recvData ctx+ void $ timeout rtt $ recvHS13 ctx chk else do -- receiving Client Finished- recvCF <- tls13stRecvCF <$> getTLS13State ctx+ let chk = tls13stRecvCF <$> getTLS13State ctx+ recvCF <- chk unless recvCF $ do -- no chance to measure RTT before receiving CF -- fixme: 1sec is good enough?- void $ timeout 1000000 $ recvData ctx+ let rtt = 1000000+ void $ timeout rtt $ recvHS13 ctx chk bye_ ctx bye_ :: MonadIO m => Context -> m ()@@ -130,7 +145,7 @@ -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon.-getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString)+getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -- | If the Server Name Indication extension has been used, return the@@ -173,12 +188,12 @@ -- All chunks are protected with the same write lock because we don't -- want to interleave writes from other threads in the middle of our -- possibly large write.- let len = ctxFragmentSize ctx- mapM_ (mapChunks_ len sendP) (L.toChunks dataToSend)+ mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3+ mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF.-recvData :: MonadIO m => Context -> m B.ByteString+recvData :: MonadIO m => Context -> m ByteString recvData ctx = liftIO $ do tls13 <- tls13orLater ctx withReadLock ctx $ do@@ -192,15 +207,15 @@ -- will impact the validity of the context. if tls13 then recvData13 ctx else recvData12 ctx -recvData12 :: Context -> IO B.ByteString+recvData12 :: Context -> IO ByteString recvData12 ctx = do pkt <- recvPacket12 ctx- either (onError terminate) process pkt+ either (onError terminate12) process pkt where- process (Handshake [ch@ClientHello{}]) =- handshakeWith ctx ch >> recvData12 ctx- process (Handshake [hr@HelloRequest]) =- handshakeWith ctx hr >> recvData12 ctx+ process (Handshake [ch@ClientHello{}] [b]) =+ handshakeWith ctx (ch, b) >> recvData12 ctx+ process (Handshake [hr@HelloRequest] [b]) =+ handshakeWith ctx (hr, b) >> recvData12 ctx -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty@@ -217,19 +232,19 @@ -- when receiving empty appdata, we just retry to get some data. process (AppData "") = recvData12 ctx process (AppData x) = return x- process p =+ process p = do let reason = "unexpected message " ++ show p- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate12 (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - terminate = terminateWithWriteLock ctx (sendPacket12 ctx . Alert)+ terminate12 = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) -recvData13 :: Context -> IO B.ByteString+recvData13 :: Context -> IO ByteString recvData13 ctx = do mdat <- tls13stPendingRecvData <$> getTLS13State ctx case mdat of Nothing -> do pkt <- recvPacket13 ctx- either (onError terminate) process pkt+ either (onError (terminate13 ctx)) process pkt Just dat -> do modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing} return dat@@ -245,8 +260,8 @@ ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc) )- process (Handshake13 hs) = do- loopHandshake13 hs+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. process (AppData13 "") = recvData13 ctx@@ -260,14 +275,14 @@ return x | otherwise -> let reason = "early data overflow"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason EarlyDataNotAllowed n | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x"- | otherwise ->+ | otherwise -> do let reason = "early data deprotect overflow"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do@@ -276,43 +291,53 @@ then recvData13 ctx else do let reason = "CSS after Finished"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- process p =+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ process p = do let reason = "unexpected message " ++ show p- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment.- loopHandshake13 (NewSessionTicket13 life add nonce label exts : hs) = do+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole- unless (role == ClientRole) $+ unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- This part is similar to handshake code, so protected with -- read+write locks (which is also what we use for all calls to the -- session manager). 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- let label' = B.copy label- void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata+ let ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}- loopHandshake13 hs- loopHandshake13 (KeyUpdate13 mode : hs) = do+ loopHandshake13 hbs+ loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+ let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs+ when multipleKeyUpdate $ do+ let reason = "Multiple KeyUpdate is not allowed in one record"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment hs+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ checkAlignment ctx established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -325,52 +350,117 @@ -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState- loopHandshake13 hs+ loopHandshake13 hbs else do let reason = "received key update before established"- terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- loopHandshake13 (h@CertRequest13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h@Certificate13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h : hs) = do- mPendingRecvAction <- popPendingRecvAction ctx- case mPendingRecvAction of- Nothing ->- let reason = "unexpected handshake message " ++ show h- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Just action -> do- -- Pending actions are executed with read+write locks, just- -- like regular handshake code.- withWriteLock ctx $- handleException ctx $ do- case action of- PendingRecvAction needAligned pa -> do- when needAligned $ checkAlignment hs- processHandshake13 ctx h- pa h- PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment hs- d <- transcriptHash ctx- processHandshake13 ctx h- pa d h- -- Client: after receiving SH, app data is coming.- -- this loop tries to receive it.- -- App key must be installed before receiving- -- the app data.- sendCFifNecessary ctx- loopHandshake13 hs+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- Client only+ loopHandshake13 ((h@CertRequest13{}, _b) : hbs) =+ postHandshakeAuthWith ctx h >> loopHandshake13 hbs+ loopHandshake13 (hb@(h, _) : hbs) = do+ rtt0 <- tls13st0RTT <$> getTLS13State ctx+ when rtt0 $ case h of+ ServerHello13 SH{..} ->+ when (isHelloRetryRequest shRandom) $ do+ clearTxRecordState ctx+ let reason = "HRR is not allowed for 0-RTT"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ _ -> return ()+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs - terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)+recvHS13 :: Context -> IO Bool -> IO ()+recvHS13 ctx breakLoop = do+ pkt <- recvPacket13 ctx+ -- fixme: Left+ either (\_ -> return ()) process pkt+ where+ -- UserCanceled MUST be followed by a CloseNotify.+ process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx+ process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs+ stop <- breakLoop+ unless stop $ recvHS13 ctx breakLoop+ process _ = recvHS13 ctx breakLoop - checkAlignment hs = do- complete <- isRecvComplete ctx- unless (complete && null hs) $- let reason = "received message not aligned with record boundary"- in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ loopHandshake13 [] = return ()+ -- fixme: some implementations send multiple NST at the same time.+ -- Only the first one is used at this moment.+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do+ role <- usingState_ ctx S.getRole+ unless (role == ClientRole) $ do+ let reason = "Session ticket is allowed for client only"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- This part is similar to handshake code, so protected with+ -- read+write locks (which is also what we use for all calls to the+ -- session manager).+ withWriteLock ctx $ do+ Just resumptionSecret <- usingHState ctx getTLS13ResumptionSecret+ (_, usedCipher, _, _) <- getTxRecordState ctx+ let choice = makeCipherChoice TLS13 usedCipher+ psk = derivePSK choice resumptionSecret nonce+ 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+ let ticket' = B.copy ticket+ void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata+ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}+ loopHandshake13 hbs+ loopHandshake13 (hb : hbs) = do+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs +terminate13+ :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a+terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)++popAction :: Context -> Handshake13R -> IO Bool+popAction ctx hb@(h, _b) = do+ mPendingRecvAction <- popPendingRecvAction ctx+ case mPendingRecvAction of+ Nothing -> return False+ Just action -> do+ -- Pending actions are executed with read+write locks, just+ -- like regular handshake code.+ withWriteLock ctx $+ handleException ctx $ do+ case action of+ PendingRecvAction needAligned pa -> do+ when needAligned $ checkAlignment ctx+ updateTranscriptHash13 ctx hb+ pa h+ PendingRecvActionSelfUpdate needAligned pa -> do+ when needAligned $ checkAlignment ctx+ pa hb+ PendingRecvActionHash needAligned pa -> do+ when needAligned $ checkAlignment ctx+ d <- transcriptHash ctx "Pending action"+ updateTranscriptHash13 ctx hb+ pa d h+ -- Client: after receiving SH, app data is coming.+ -- this loop tries to receive it.+ -- App key must be installed before receiving+ -- the app data.+ sendCFifNecessary ctx+ return True++checkAlignment :: Context -> IO ()+checkAlignment ctx = do+ complete <- isRecvComplete ctx+ unless complete $ do+ let reason = "received message not aligned with record boundary"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions tryBye :: Context -> IO ()@@ -378,15 +468,16 @@ onError :: Monad m- => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString)+ => (TLSError -> AlertLevel -> AlertDescription -> String -> m ByteString) -> TLSError- -> m B.ByteString+ -> m ByteString onError _ Error_EOF = -- Not really an error. return B.empty-onError terminate err =- let (lvl, ad) = errorToAlert err- in terminate err lvl ad (errorToAlertMessage err)+onError terminate err = terminate err lvl ad reason+ where+ (lvl, ad) = errorToAlert err+ reason = errorToAlertMessage err terminateWithWriteLock :: Context@@ -396,16 +487,22 @@ -> AlertDescription -> String -> IO a-terminateWithWriteLock ctx send err level desc reason = do- session <- usingState_ ctx getSession- -- Session manager is always invoked with read+write locks, so we merge this- -- with the alert packet being emitted.- withWriteLock ctx $ do+terminateWithWriteLock ctx send err level desc reason = withWriteLock ctx $ do+ tls13 <- tls13orLater ctx+ unless tls13 $ do+ -- TLS 1.2 uses the same session ID and session data+ -- for all resumed sessions.+ --+ -- TLS 1.3 changes session data for every resumed session.+ session <- usingState_ ctx getSession case session of Session Nothing -> return ()- Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid- catchException (send [(level, desc)]) (\_ -> return ())+ Session (Just sid) ->+ -- calling even session ticket manager anyway+ sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid+ catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx+ debugError (ctxDebug ctx) reason E.throwIO (Terminated False reason err) {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-}@@ -413,45 +510,3 @@ -- | same as recvData but returns a lazy bytestring. recvData' :: MonadIO m => Context -> m L.ByteString recvData' ctx = L.fromChunks . (: []) <$> recvData ctx--keyUpdate- :: Context- -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))- -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())- -> IO ()-keyUpdate ctx getState setState = do- (usedHash, usedCipher, level, applicationSecretN) <- getState ctx- unless (level == CryptApplicationSecret) $- throwCore $- Error_Protocol- "tried key update without application traffic secret"- InternalError- let applicationSecretN1 =- hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $- hashDigestSize usedHash- setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)---- | How to update keys in TLS 1.3-data KeyUpdateRequest- = -- | Unidirectional key update- OneWay- | -- | Bidirectional key update (normal case)- TwoWay- deriving (Eq, Show)---- | Updating appication traffic secrets for TLS 1.3.--- If this API is called for TLS 1.3, 'True' is returned.--- Otherwise, 'False' is returned.-updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool-updateKey ctx way = liftIO $ do- tls13 <- tls13orLater ctx- when tls13 $ do- let req = case way of- OneWay -> UpdateNotRequested- TwoWay -> UpdateRequested- -- Write lock wraps both actions because we don't want another packet to- -- be sent by another thread before the Tx state is updated.- withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]- keyUpdate ctx getTxRecordState setTxRecordState- return tls13
Network/TLS/Credentials.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Network.TLS.Credentials ( Credential,@@ -15,14 +16,14 @@ ) where import Data.X509+import qualified Data.X509 as X509 import Data.X509.File import Data.X509.Memory+ import Network.TLS.Crypto import Network.TLS.Imports-import Network.TLS.X509--import qualified Data.X509 as X509 import qualified Network.TLS.Struct as TLS+import Network.TLS.X509 type Credential = (CertificateChain, PrivKey)
Network/TLS/Crypto.hs view
@@ -7,6 +7,7 @@ HashCtx, hashInit, hashUpdate,+ hashUpdates, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH,@@ -15,6 +16,7 @@ -- * Hash hash,+ hashChunks, Hash (..), hashName, hashDigestSize,@@ -56,9 +58,13 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random-import qualified Data.ByteArray as B (convert)+import Data.ASN1.BinaryEncoding (BER (..), DER (..))+import Data.ASN1.Encoding+import Data.ASN1.Types+import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B-+import Data.Proxy import Data.X509 ( PrivKey (..), PrivKeyEC (..),@@ -67,16 +73,13 @@ SerializedPoint (..), ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint)+ import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types import Network.TLS.Imports -import Data.ASN1.BinaryEncoding (BER (..), DER (..))-import Data.ASN1.Encoding-import Data.ASN1.Types--import Data.Proxy+---------------------------------------------------------------- {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey@@ -115,7 +118,9 @@ pg (DH.Params p g _) = (p, g) table =- [ (pg prms, grp) | grp <- availableFFGroups, let prms = fromJust $ dhParamsForGroup grp+ [ (pg prms, grp)+ | grp <- availableFFGroups+ , let prms = fromJust $ dhParamsForGroup grp ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group@@ -136,24 +141,32 @@ hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) hashInit SHA1_MD5 = HashContextSSL H.hashInit H.hashInit -hashUpdate :: HashContext -> B.ByteString -> HashCtx+hashUpdate :: HashContext -> ByteString -> HashCtx hashUpdate (HashContext (ContextSimple h)) b = HashContext $ ContextSimple (H.hashUpdate h b) hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) +hashUpdates :: HashContext -> [ByteString] -> HashCtx+hashUpdates (HashContext (ContextSimple h)) xs = HashContext $ ContextSimple (H.hashUpdates h xs)+hashUpdates (HashContextSSL sha1Ctx md5Ctx) xs =+ HashContextSSL (H.hashUpdates sha1Ctx xs) (H.hashUpdates md5Ctx xs)++hashChunks :: Hash -> [ByteString] -> ByteString+hashChunks h xs = hashFinal $ hashUpdates (hashInit h) xs+ hashUpdateSSL :: HashCtx- -> (B.ByteString, B.ByteString)+ -> (ByteString, ByteString) -- ^ (for the md5 context, for the sha1 context) -> HashCtx hashUpdateSSL (HashContext _) _ = error "internal error: update SSL without a SSL Context" hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1, b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) -hashFinal :: HashCtx -> B.ByteString-hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h+hashFinal :: HashCtx -> ByteString+hashFinal (HashContext (ContextSimple h)) = convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) =- B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)]+ B.concat [convert (H.hashFinalize md5Ctx), convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show, Eq)@@ -170,20 +183,14 @@ type HashCtx = HashContext -hash :: Hash -> B.ByteString -> B.ByteString-hash MD5 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.MD5) $ b-hash SHA1 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA1) $ b-hash SHA224 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA224) $ b-hash SHA256 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA256) $ b-hash SHA384 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA384) $ b-hash SHA512 b = B.convert . (H.hash :: B.ByteString -> H.Digest H.SHA512) $ b-hash SHA1_MD5 b =- B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)]- where- sha1Hash :: B.ByteString -> H.Digest H.SHA1- sha1Hash = H.hash- md5Hash :: B.ByteString -> H.Digest H.MD5- md5Hash = H.hash+hash :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba+hash MD5 b = convert (H.hash b :: H.Digest H.MD5)+hash SHA1 b = convert (H.hash b :: H.Digest H.SHA1)+hash SHA224 b = convert (H.hash b :: H.Digest H.SHA224)+hash SHA256 b = convert (H.hash b :: H.Digest H.SHA256)+hash SHA384 b = convert (H.hash b :: H.Digest H.SHA384)+hash SHA512 b = convert (H.hash b :: H.Digest H.SHA512)+hash SHA1_MD5 b = BA.concat [hash MD5 b, hash SHA1 b] hashName :: Hash -> String hashName = show@@ -214,12 +221,12 @@ generalizeRSAError (Right x) = Right x kxEncrypt- :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt- :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) @@ -356,9 +363,9 @@ Just sign -> Right (ECDSA.signatureToIntegers prx sign) unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg =- return $ Right $ B.convert $ Ed25519.sign pk pub msg+ return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =- return $ Right $ B.convert $ Ed448.sign pk pub msg+ return $ Right $ convert $ Ed448.sign pk pub msg kxSign _ _ _ _ = return (Left KxUnsupported) @@ -424,6 +431,8 @@ kxSupportedPrivKeyEC privkey = case ecPrivKeyCurveName privkey of Just ECC.SEC_p256r1 -> True+ Just ECC.SEC_p384r1 -> True+ Just ECC.SEC_p521r1 -> True _ -> False -- Perform a public-key operation with a parameterized ECC implementation when@@ -444,6 +453,10 @@ Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs+ Just ECC.SEC_p384r1 ->+ maybeCryptoError $ withProxy p384 <$> ECDSA.decodePublic p384 bs+ Just ECC.SEC_p521r1 ->+ maybeCryptoError $ withProxy p521 <$> ECDSA.decodePublic p521 bs Just curveName -> let curve = ECC.getCurveByName curveName pub = unserializePoint curve pt@@ -473,9 +486,17 @@ -- using ECDSA.decodePrivate, unfortunately the data type chosen in -- x509 was Integer. maybeCryptoError $ withProxy p256 <$> ECDSA.scalarFromInteger p256 d+ Just ECC.SEC_p384r1 ->+ maybeCryptoError $ withProxy p384 <$> ECDSA.scalarFromInteger p384 d+ Just ECC.SEC_p521r1 ->+ maybeCryptoError $ withProxy p521 <$> ECDSA.scalarFromInteger p521 d Just curveName -> Just $ withUnsupported curveName where d = privkeyEC_priv privkey p256 :: Proxy ECDSA.Curve_P256R1 p256 = Proxy+p384 :: Proxy ECDSA.Curve_P384R1+p384 = Proxy+p521 :: Proxy ECDSA.Curve_P521R1+p521 = Proxy
Network/TLS/Crypto/DH.hs view
@@ -21,13 +21,15 @@ import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH-import qualified Data.ByteArray as B+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA+ import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params-type DHKey = DH.SharedKey+type DHKey = ScrubbedBytes dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber@@ -45,12 +47,12 @@ return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey-dhGetShared params priv pub =- stripLeadingZeros (DH.getShared params priv pub)+dhGetShared params priv pub = stripLeadingZeros sec where+ DH.SharedKey sec = DH.getShared params priv pub -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.- stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)+ stripLeadingZeros sb = snd $ BA.span (== 0) sb -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.
Network/TLS/Crypto/IES.hs view
@@ -1,20 +1,25 @@--- |+-- | (Elliptic Curve) Integrated Encryption Scheme+-- KEM(Key Encapsulation Mechanism) based APIs+-- -- Module : Network.TLS.Crypto.IES -- License : BSD-style -- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp> -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.IES (- GroupPublic,+ GroupPublicA,+ GroupPublicB, GroupPrivate, GroupKey, -- * Group methods groupGenerateKeyPair,- groupGetPubShared,- groupGetShared,- encodeGroupPublic,- decodeGroupPublic,+ groupEncapsulate,+ groupDecapsulate,+ groupEncodePublicA,+ groupDecodePublicA,+ groupEncodePublicB,+ groupDecodePublicB, -- * Compatibility with 'Network.TLS.Crypto.DH' dhParamsForGroup,@@ -23,19 +28,25 @@ ) where import Control.Arrow-import Crypto.ECC+import Crypto.ECC as ECC import Crypto.Error import Crypto.Number.Generate-import Crypto.PubKey.DH hiding (generateParams)+import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..))+import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES-import qualified Data.ByteArray as B+import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768)+import qualified Crypto.PubKey.ML_KEM as ML+import Data.ByteArray (ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import Data.Proxy+ import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) +{- FOURMOLU_DISABLE -} data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) | GroupPri_P384 (Scalar Curve_P384R1)@@ -47,23 +58,59 @@ | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber+ | GroupPri_MLKEM512 (ML.DecapsulationKey ML_KEM_512)+ | GroupPri_MLKEM768 (ML.DecapsulationKey ML_KEM_768)+ | GroupPri_MLKEM1024 (ML.DecapsulationKey ML_KEM_1024)+ | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey ML_KEM_768)+ | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey ML_KEM_768)+ | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey ML_KEM_1024) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -data GroupPublic- = GroupPub_P256 (Point Curve_P256R1)- | GroupPub_P384 (Point Curve_P384R1)- | GroupPub_P521 (Point Curve_P521R1)- | GroupPub_X255 (Point Curve_X25519)- | GroupPub_X448 (Point Curve_X448)- | GroupPub_FFDHE2048 PublicNumber- | GroupPub_FFDHE3072 PublicNumber- | GroupPub_FFDHE4096 PublicNumber- | GroupPub_FFDHE6144 PublicNumber- | GroupPub_FFDHE8192 PublicNumber+{- FOURMOLU_DISABLE -}+data GroupPublicA+ = GroupPubA_P256 (Point Curve_P256R1)+ | GroupPubA_P384 (Point Curve_P384R1)+ | GroupPubA_P521 (Point Curve_P521R1)+ | GroupPubA_X255 (Point Curve_X25519)+ | GroupPubA_X448 (Point Curve_X448)+ | GroupPubA_FFDHE2048 PublicNumber+ | GroupPubA_FFDHE3072 PublicNumber+ | GroupPubA_FFDHE4096 PublicNumber+ | GroupPubA_FFDHE6144 PublicNumber+ | GroupPubA_FFDHE8192 PublicNumber+ | GroupPubA_MLKEM512 (ML.EncapsulationKey ML_KEM_512)+ | GroupPubA_MLKEM768 (ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_MLKEM1024 (ML.EncapsulationKey ML_KEM_1024)+ | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey ML_KEM_768)+ | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey ML_KEM_1024) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -type GroupKey = SharedSecret+{- FOURMOLU_DISABLE -}+data GroupPublicB+ = GroupPubB_P256 (Point Curve_P256R1)+ | GroupPubB_P384 (Point Curve_P384R1)+ | GroupPubB_P521 (Point Curve_P521R1)+ | GroupPubB_X255 (Point Curve_X25519)+ | GroupPubB_X448 (Point Curve_X448)+ | GroupPubB_FFDHE2048 PublicNumber+ | GroupPubB_FFDHE3072 PublicNumber+ | GroupPubB_FFDHE4096 PublicNumber+ | GroupPubB_FFDHE6144 PublicNumber+ | GroupPubB_FFDHE8192 PublicNumber+ | GroupPubB_MLKEM512 (ML.Ciphertext ML_KEM_512)+ | GroupPubB_MLKEM768 (ML.Ciphertext ML_KEM_768)+ | GroupPubB_MLKEM1024 (ML.Ciphertext ML_KEM_1024)+ | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext ML_KEM_768)+ | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext ML_KEM_768)+ | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext ML_KEM_1024)+ deriving (Eq, Show)+{- FOURMOLU_ENABLE -} +type GroupKey = ScrubbedBytes+ p256 :: Proxy Curve_P256R1 p256 = Proxy @@ -79,7 +126,16 @@ x448 :: Proxy Curve_X448 x448 = Proxy -dhParamsForGroup :: Group -> Maybe Params+mlkem512 :: Proxy ML_KEM_512+mlkem512 = Proxy++mlkem768 :: Proxy ML_KEM_768+mlkem768 = Proxy++mlkem1024 :: Proxy ML_KEM_1024+mlkem1024 = Proxy++dhParamsForGroup :: Group -> Maybe DH.Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096@@ -87,26 +143,47 @@ dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic)+groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA) groupGenerateKeyPair P256 =- (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256+ (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 =- (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384+ (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 =- (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521+ (GroupPri_P521, GroupPubA_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 =- (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519+ (GroupPri_X255, GroupPubA_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 =- (GroupPri_X448, GroupPub_X448) `fs` curveGenerateKeyPair x448-groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048-groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072-groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096-groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144-groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192+ (GroupPri_X448, GroupPubA_X448) `fs` curveGenerateKeyPair x448+groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPubA_FFDHE2048+groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPubA_FFDHE3072+groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPubA_FFDHE4096+groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144+groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192+groupGenerateKeyPair MLKEM512 = do+ (e, d) <- ML.generate mlkem512+ return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e)+groupGenerateKeyPair MLKEM768 = do+ (e, d) <- ML.generate mlkem768+ return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e)+groupGenerateKeyPair MLKEM1024 = do+ (e, d) <- ML.generate mlkem1024+ return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e)+groupGenerateKeyPair X25519MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair x25519+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2))+groupGenerateKeyPair P256MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p256+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2))+groupGenerateKeyPair P384MLKEM1024 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p384+ (e2, d2) <- ML.generate mlkem1024+ return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" dhGroupGenerateKeyPair- :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber)+ :: MonadRandom r => Group -> r (DH.Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096)@@ -114,148 +191,320 @@ dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) -addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b)+addParams :: Functor f => DH.Params -> f (a, b) -> f (DH.Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) fs :: MonadRandom r- => (Scalar a -> GroupPrivate, Point a -> GroupPublic)+ => (Scalar a -> GroupPrivate, Point a -> GroupPublicA) -> r (KeyPair a)- -> r (GroupPrivate, GroupPublic)+ -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) +fs' :: Monad m => m (KeyPair curve) -> m (Scalar curve, Point curve)+fs' action = do+ keypair <- action+ let pub = keypairGetPublic keypair+ pri = keypairGetPrivate keypair+ return (pri, pub)+ gen :: MonadRandom r- => Params+ => DH.Params -> Int -> (PrivateNumber -> GroupPrivate)- -> (PublicNumber -> GroupPublic)- -> r (GroupPrivate, GroupPublic)+ -> (PublicNumber -> GroupPublicA)+ -> r (GroupPrivate, GroupPublicA) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits gen' :: MonadRandom r- => Params+ => DH.Params -> Int -> r (PrivateNumber, PublicNumber)-gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared- :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey))-groupGetPubShared (GroupPub_P256 pub) =- fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub-groupGetPubShared (GroupPub_P384 pub) =- fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub-groupGetPubShared (GroupPub_P521 pub) =- fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub-groupGetPubShared (GroupPub_X255 pub) =- fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub-groupGetPubShared (GroupPub_X448 pub) =- fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192+groupEncapsulate+ :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey))+groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub+groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub+groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub+groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub+groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub+groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048+groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072+groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096+groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144+groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192+groupEncapsulate (GroupPubA_MLKEM512 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM512 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM768 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM768 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM1024 pub) = do+ (sec, ct) <- ML.encapsulate pub+ return $ Just (GroupPubB_MLKEM1024 ct, convert sec)+groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' x25519 e1+ (k2, c2) <- ML.encapsulate e2+ -- Sec 4.1: Specifically, the order of shares in the concatenation+ -- has been reversed.+ return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1)+groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' p256 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' p384 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) dhGroupGetPubShared- :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))-dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub-dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub-dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub-dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub-dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub+ :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey))+dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub+dhGroupGetPubShared FFDHE3072 pub = getDHPubShared' ffdhe3072 exp3072 pub+dhGroupGetPubShared FFDHE4096 pub = getDHPubShared' ffdhe4096 exp4096 pub+dhGroupGetPubShared FFDHE6144 pub = getDHPubShared' ffdhe6144 exp6144 pub+dhGroupGetPubShared FFDHE8192 pub = getDHPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing -getPubShared+getECDHPubShared+ :: (MonadRandom m, EllipticCurveDH curve)+ => (Point curve -> GroupPublicB)+ -> proxy curve+ -> Point curve+ -> m (Maybe (GroupPublicB, GroupKey))+getECDHPubShared tag proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (tag p, s)++getECDHPubShared'+ :: (MonadRandom m, EllipticCurveDH curve)+ => proxy curve+ -> Point curve+ -> m (Maybe (Point curve, GroupKey))+getECDHPubShared' proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (p, s)++getDHPubShared :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> (PublicNumber -> GroupPublic)- -> r (Maybe (GroupPublic, GroupKey))-getPubShared params expBits pub pubTag+ -> (PublicNumber -> GroupPublicB)+ -> r (Maybe (GroupPublicB, GroupKey))+getDHPubShared params expBits pub pubTag | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let mypub = calculatePublic params mypri- let SharedKey share = getShared params mypri pub- return $ Just (pubTag mypub, SharedSecret share)+ let mypub = DH.calculatePublic params mypri+ DH.SharedKey share = DH.getShared params mypri pub+ return $ Just (pubTag mypub, share) -getPubShared'+getDHPubShared' :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> r (Maybe (PublicNumber, SharedKey))-getPubShared' params expBits pub+ -> r (Maybe (PublicNumber, GroupKey))+getDHPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let share = stripLeadingZeros (getShared params mypri pub)- return $ Just (calculatePublic params mypri, SharedKey share)+ let share = stripLeadingZeros (DH.getShared params mypri pub)+ return $ Just (DH.calculatePublic params mypri, convert share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey-groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri-groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri-groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri-groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri-groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri-groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri-groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri-groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri-groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri-groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri-groupGetShared _ _ = Nothing+unwrap :: SharedSecret -> GroupKey+unwrap (ECC.SharedSecret sec) = sec -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret-calcShared params pub pri- | valid params pub = Just $ SharedSecret share+groupDecapsulate :: GroupPublicB -> GroupPrivate -> Maybe GroupKey+groupDecapsulate (GroupPubB_P256 pub) (GroupPri_P256 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 pub pri+groupDecapsulate (GroupPubB_P384 pub) (GroupPri_P384 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 pub pri+groupDecapsulate (GroupPubB_P521 pub) (GroupPri_P521 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p521 pub pri+groupDecapsulate (GroupPubB_X255 pub) (GroupPri_X255 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 pub pri+groupDecapsulate (GroupPubB_X448 pub) (GroupPri_X448 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x448 pub pri+groupDecapsulate (GroupPubB_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcDHShared ffdhe2048 pub pri+groupDecapsulate (GroupPubB_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcDHShared ffdhe3072 pub pri+groupDecapsulate (GroupPubB_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcDHShared ffdhe4096 pub pri+groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri+groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri+groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs2 <> bs1)+groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs1 <> bs2)+groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do+ bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1+ let bs2 = convert $ ML.decapsulate s2 p2+ return (bs1 <> bs2)+groupDecapsulate _ _ = Nothing++calcDHShared :: DH.Params -> PublicNumber -> PrivateNumber -> Maybe GroupKey+calcDHShared params pub pri+ | valid params pub = Just $ convert share | otherwise = Nothing where- SharedKey share = getShared params pri pub+ share = DH.getShared params pri pub -encodeGroupPublic :: GroupPublic -> ByteString-encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p-encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p-encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p-encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p-encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p-encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p-encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p-encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p-encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p-encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA :: GroupPublicA -> ByteString+groupEncodePublicA (GroupPubA_P256 p) = encodePoint p256 p+groupEncodePublicA (GroupPubA_P384 p) = encodePoint p384 p+groupEncodePublicA (GroupPubA_P521 p) = encodePoint p521 p+groupEncodePublicA (GroupPubA_X255 p) = encodePoint x25519 p+groupEncodePublicA (GroupPubA_X448 p) = encodePoint x448 p+groupEncodePublicA (GroupPubA_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicA (GroupPubA_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA (GroupPubA_MLKEM512 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM768 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM1024 p) = ML.encode p+groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) =+ ML.encode p2 <> encodePoint x25519 p1+groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> ML.encode p2+groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> ML.encode p2 -enc :: Params -> PublicNumber -> ByteString-enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p+groupEncodePublicB :: GroupPublicB -> ByteString+groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p+groupEncodePublicB (GroupPubB_P384 p) = encodePoint p384 p+groupEncodePublicB (GroupPubB_P521 p) = encodePoint p521 p+groupEncodePublicB (GroupPubB_X255 p) = encodePoint x25519 p+groupEncodePublicB (GroupPubB_X448 p) = encodePoint x448 p+groupEncodePublicB (GroupPubB_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicB (GroupPubB_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicB (GroupPubB_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicB (GroupPubB_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicB (GroupPubB_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicB (GroupPubB_MLKEM512 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM768 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM1024 p) = convert p+groupEncodePublicB (GroupPubB_X25519MLKEM768 (p1, p2)) =+ convert p2 <> encodePoint x25519 p1+groupEncodePublicB (GroupPubB_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> convert p2+groupEncodePublicB (GroupPubB_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> convert p2 -decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic-decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs-decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs-decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs-decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs-decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs-decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs-decodeGroupPublic _ _ = error "decodeGroupPublic"+enc :: DH.Params -> PublicNumber -> ByteString+enc params (PublicNumber p) = i2ospOf_ ((DH.params_bits params + 7) `div` 8) p +groupDecodePublicA :: Group -> ByteString -> Either CryptoError GroupPublicA+groupDecodePublicA P256 bs = eitherCryptoError $ GroupPubA_P256 <$> decodePoint p256 bs+groupDecodePublicA P384 bs = eitherCryptoError $ GroupPubA_P384 <$> decodePoint p384 bs+groupDecodePublicA P521 bs = eitherCryptoError $ GroupPubA_P521 <$> decodePoint p521 bs+groupDecodePublicA X25519 bs = eitherCryptoError $ GroupPubA_X255 <$> decodePoint x25519 bs+groupDecodePublicA X448 bs = eitherCryptoError $ GroupPubA_X448 <$> decodePoint x448 bs+groupDecodePublicA FFDHE2048 bs = Right . GroupPubA_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE3072 bs = Right . GroupPubA_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicA MLKEM512 bs = case ML.decode mlkem512 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM512 p+groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM768 p+groupDecodePublicA MLKEM1024 bs = case ML.decode mlkem1024 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM1024 p+groupDecodePublicA X25519MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 1184 bs+ in case ML.decode mlkem768 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1)+groupDecodePublicA P256MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 65 bs+ in case ML.decode mlkem768 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1)+groupDecodePublicA P384MLKEM1024 bs =+ let (bs1, bs2) = BA.splitAt 97 bs+ in case ML.decode mlkem1024 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_P384MLKEM1024 (p2, p1)+groupDecodePublicA _ _ = error "groupDecodePublicA"++groupDecodePublicB :: Group -> ByteString -> Either CryptoError GroupPublicB+groupDecodePublicB P256 bs = eitherCryptoError $ GroupPubB_P256 <$> decodePoint p256 bs+groupDecodePublicB P384 bs = eitherCryptoError $ GroupPubB_P384 <$> decodePoint p384 bs+groupDecodePublicB P521 bs = eitherCryptoError $ GroupPubB_P521 <$> decodePoint p521 bs+groupDecodePublicB X25519 bs = eitherCryptoError $ GroupPubB_X255 <$> decodePoint x25519 bs+groupDecodePublicB X448 bs = eitherCryptoError $ GroupPubB_X448 <$> decodePoint x448 bs+groupDecodePublicB FFDHE2048 bs = Right . GroupPubB_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE3072 bs = Right . GroupPubB_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicB MLKEM512 bs = case ML.decode mlkem512 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM512 p+groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM768 p+groupDecodePublicB MLKEM1024 bs = case ML.decode mlkem1024 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM1024 p+groupDecodePublicB X25519MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 1088 bs+ in case ML.decode mlkem768 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1)+groupDecodePublicB P256MLKEM768 bs =+ let (bs1, bs2) = BA.splitAt 65 bs+ in case ML.decode mlkem768 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1)+groupDecodePublicB P384MLKEM1024 bs =+ let (bs1, bs2) = BA.splitAt 97 bs+ in case ML.decode mlkem1024 bs2 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_P384MLKEM1024 (p2, p1)+groupDecodePublicB _ _ = error "groupDecodePublicB"+ -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.-valid :: Params -> PublicNumber -> Bool-valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1+valid :: DH.Params -> PublicNumber -> Bool+valid (DH.Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.-stripLeadingZeros :: SharedKey -> B.ScrubbedBytes-stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb+stripLeadingZeros :: DH.SharedKey -> ScrubbedBytes+stripLeadingZeros (DH.SharedKey sb) = snd $ BA.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber
Network/TLS/Crypto/Types.hs view
@@ -19,11 +19,19 @@ FFDHE3072, FFDHE4096, FFDHE6144,- FFDHE8192+ FFDHE8192,+ MLKEM512,+ MLKEM768,+ MLKEM1024,+ X25519MLKEM768,+ P256MLKEM768,+ P384MLKEM1024 ), availableFFGroups, availableECGroups,+ availableHybridGroups, supportedNamedGroups,+ supportedNamedGroupsTLS13, KeyExchangeSignatureAlg (..), ) where @@ -55,6 +63,18 @@ pattern FFDHE6144 = Group 259 pattern FFDHE8192 :: Group pattern FFDHE8192 = Group 260+pattern MLKEM512 :: Group+pattern MLKEM512 = Group 512+pattern MLKEM768 :: Group+pattern MLKEM768 = Group 513+pattern MLKEM1024 :: Group+pattern MLKEM1024 = Group 514+pattern X25519MLKEM768 :: Group+pattern X25519MLKEM768 = Group 4588+pattern P256MLKEM768 :: Group+pattern P256MLKEM768 = Group 4587+pattern P384MLKEM1024 :: Group+pattern P384MLKEM1024 = Group 4589 instance Show Group where show P256 = "P256"@@ -67,6 +87,12 @@ show FFDHE4096 = "FFDHE4096" show FFDHE6144 = "FFDHE6144" show FFDHE8192 = "FFDHE8192"+ show MLKEM512 = "MLKEM512"+ show MLKEM768 = "MLKEM768"+ show MLKEM1024 = "MLKEM1024"+ show X25519MLKEM768 = "X25519MLKEM768"+ show P256MLKEM768 = "P256MLKEM768"+ show P384MLKEM1024 = "P384MLKEM1024" show (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} @@ -76,8 +102,40 @@ availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] +availableHybridGroups :: [Group]+availableHybridGroups = [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]++-- | A list for named groups. The ordering is for client preference+-- because server preference is not used in our server+-- implementation. supportedNamedGroups :: [Group]-supportedNamedGroups = [X25519, X448, P256, FFDHE3072, FFDHE4096, P384, FFDHE6144, FFDHE8192, P521]+supportedNamedGroups =+ [ X25519 -- 128 bits security+ , P256 -- 128 bits security+ , P384 -- 192 bits security+ , X448 -- 224 bits security+ , P521 -- 256 bits security+ -- , FFDHE2048 -- 103 bits security+ , FFDHE3072 -- 125 bits security+ , FFDHE4096 -- 150 bits security+ , FFDHE6144 -- 175 bits security+ , FFDHE8192 -- 192 bits security+ , X25519MLKEM768+ , P256MLKEM768+ , P384MLKEM1024+ , -- , MLKEM512+ MLKEM768+ , MLKEM1024+ ]++supportedNamedGroupsTLS13 :: [[Group]]+supportedNamedGroupsTLS13 =+ [ [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]+ , [X25519, P256]+ , [P384, X448, P521]+ , [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192]+ , [MLKEM768, MLKEM1024]+ ] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3).
+ Network/TLS/Error.hs view
@@ -0,0 +1,198 @@+{-# 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+pattern EchRequired :: AlertDescription+pattern EchRequired = AlertDescription 121 -- draft++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 EchRequired = "EchRequired"+ show (AlertDescription x) = "AlertDescription " ++ show x+{- FOURMOLU_ENABLE -}
Network/TLS/Extension.hs view
@@ -1,627 +1,1175 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}---- | Basic extensions are defined in RFC 6066-module Network.TLS.Extension (- Extension (..),- supportedExtensions,- definedExtensions,- -- all implemented extensions- ServerNameType (..),- ServerName (..),- MaxFragmentLength (..),- MaxFragmentEnum (..),- SecureRenegotiation (..),- ApplicationLayerProtocolNegotiation (..),- ExtendedMainSecret (..),- SupportedGroups (..),- Group (..),- EcPointFormatsSupported (..),- EcPointFormat (- EcPointFormat,- EcPointFormat_Uncompressed,- EcPointFormat_AnsiX962_compressed_prime,- EcPointFormat_AnsiX962_compressed_char2- ),- SessionTicket (..),- HeartBeat (..),- HeartBeatMode (- HeartBeatMode,- HeartBeat_PeerAllowedToSend,- HeartBeat_PeerNotAllowedToSend- ),- SignatureAlgorithms (..),- SignatureAlgorithmsCert (..),- SupportedVersions (..),- KeyShare (..),- KeyShareEntry (..),- MessageType (..),- PostHandshakeAuth (..),- PskKexMode (PskKexMode, PSK_KE, PSK_DHE_KE),- PskKeyExchangeModes (..),- PskIdentity (..),- PreSharedKey (..),- EarlyDataIndication (..),- Cookie (..),- CertificateAuthorities (..),-) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC--import Network.TLS.Crypto.Types-import Network.TLS.Struct-import Network.TLS.Types (HostName, Ticket)--import Network.TLS.Imports-import Network.TLS.Packet (- getBinaryVersion,- getDNames,- getSignatureHashAlgorithm,- putBinaryVersion,- putDNames,- putSignatureHashAlgorithm,- )-import Network.TLS.Wire----------------------------------------------------------------definedExtensions :: [ExtensionID]-definedExtensions =- [ 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_KeyShare- , EID_SignatureAlgorithmsCert- , EID_CertificateAuthorities- , EID_SecureRenegotiation- , EID_QuicTransportParameters- ]---- | all supported extensions by the implementation-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- ]----------------------------------------------------------------data MessageType- = MsgTClientHello- | MsgTServerHello- | MsgTHelloRetryRequest- | MsgTEncryptedExtensions- | MsgTNewSessionTicket- | 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.--- the associated name decoding is dependant of its name type.--- name type = 0 : hostname-newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq)--data ServerNameType- = ServerNameHostName HostName- | ServerNameOther (Word8, ByteString)- deriving (Show, Eq)--instance Extension ServerName where- extensionID _ = EID_ServerName- 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- encodeNameType (ServerNameOther (nt, opaque)) = putWord8 nt >> putBytes opaque- extensionDecode MsgTClientHello = decodeServerName- extensionDecode MsgTServerHello = decodeServerName- extensionDecode MsgTEncryptedExtensions = decodeServerName- extensionDecode _ = error "extensionDecode: ServerName"--decodeServerName :: ByteString -> Maybe ServerName-decodeServerName = runGetMaybe $ do- len <- fromIntegral <$> getWord16- ServerName <$> getList len getServerName- where- getServerName = do- ty <- getWord8- snameParsed <- getOpaque16- let sname = B.copy snameParsed- name = case ty of- 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion- _ -> ServerNameOther (ty, sname)- return (1 + 2 + B.length sname, name)------------------------------------------------------------------ | Max fragment extension with length from 512 bytes to 4096 bytes------ RFC 6066 defines:--- If a server receives a maximum fragment length negotiation request--- for a value other than the allowed values, it MUST abort the--- handshake with an "illegal_parameter" alert.------ So, if a server receives MaxFragmentLengthOther, it must send the alert.-data MaxFragmentLength- = MaxFragmentLength MaxFragmentEnum- | MaxFragmentLengthOther Word8- deriving (Show, Eq)--data MaxFragmentEnum- = MaxFragment512- | MaxFragment1024- | MaxFragment2048- | MaxFragment4096- deriving (Show, Eq)--instance Extension MaxFragmentLength where- extensionID _ = EID_MaxFragmentLength- extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l- where- fromMaxFragmentEnum MaxFragment512 = 1- fromMaxFragmentEnum MaxFragment1024 = 2- fromMaxFragmentEnum MaxFragment2048 = 3- fromMaxFragmentEnum MaxFragment4096 = 4- extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l- extensionDecode MsgTClientHello = decodeMaxFragmentLength- extensionDecode MsgTServerHello = decodeMaxFragmentLength- extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength- extensionDecode _ = error "extensionDecode: MaxFragmentLength"--decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength-decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8- where- toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512- toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024- toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048- toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096- toMaxFragmentEnum n = MaxFragmentLengthOther n------------------------------------------------------------------ | 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-instance Extension SupportedGroups where- extensionID _ = EID_SupportedGroups- extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups- extensionDecode MsgTClientHello = decodeSupportedGroups- extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups- extensionDecode _ = error "extensionDecode: SupportedGroups"--decodeSupportedGroups :: ByteString -> Maybe SupportedGroups-decodeSupportedGroups =- runGetMaybe (SupportedGroups . map Group <$> getWords16)----------------------------------------------------------------newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]- deriving (Show, Eq)--newtype EcPointFormat = EcPointFormat {fromEcPointFormat :: Word8}- deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern EcPointFormat_Uncompressed :: EcPointFormat-pattern EcPointFormat_Uncompressed = EcPointFormat 0-pattern EcPointFormat_AnsiX962_compressed_prime :: EcPointFormat-pattern EcPointFormat_AnsiX962_compressed_prime = EcPointFormat 1-pattern EcPointFormat_AnsiX962_compressed_char2 :: EcPointFormat-pattern EcPointFormat_AnsiX962_compressed_char2 = EcPointFormat 2--instance Show EcPointFormat where- show EcPointFormat_Uncompressed = "EcPointFormat_Uncompressed"- show EcPointFormat_AnsiX962_compressed_prime = "EcPointFormat_AnsiX962_compressed_prime"- show EcPointFormat_AnsiX962_compressed_char2 = "EcPointFormat_AnsiX962_compressed_char2"- show (EcPointFormat x) = "EcPointFormat " ++ show x-{- FOURMOLU_ENABLE -}---- on decode, filter all unknown formats-instance Extension EcPointFormatsSupported where- extensionID _ = EID_EcPointFormats- extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats- extensionDecode MsgTClientHello = decodeEcPointFormatsSupported- extensionDecode MsgTServerHello = decodeEcPointFormatsSupported- extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"--decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported-decodeEcPointFormatsSupported =- runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8)----------------------------------------------------------------newtype SessionTicket = SessionTicket Ticket- 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"----------------------------------------------------------------newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq)--newtype HeartBeatMode = HeartBeatMode {fromHeartBeatMode :: Word8}- deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern HeartBeat_PeerAllowedToSend :: HeartBeatMode-pattern HeartBeat_PeerAllowedToSend = HeartBeatMode 1-pattern HeartBeat_PeerNotAllowedToSend :: HeartBeatMode-pattern HeartBeat_PeerNotAllowedToSend = HeartBeatMode 2--instance Show HeartBeatMode where- show HeartBeat_PeerAllowedToSend = "HeartBeat_PeerAllowedToSend"- show HeartBeat_PeerNotAllowedToSend = "HeartBeat_PeerNotAllowedToSend"- show (HeartBeatMode x) = "HeartBeatMode " ++ show x-{- FOURMOLU_ENABLE -}--instance Extension HeartBeat where- extensionID _ = EID_Heartbeat- extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode- extensionDecode MsgTClientHello = decodeHeartBeat- extensionDecode MsgTServerHello = decodeHeartBeat- extensionDecode _ = error "extensionDecode: HeartBeat"--decodeHeartBeat :: ByteString -> Maybe HeartBeat-decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8----------------------------------------------------------------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]- 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 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"----------------------------------------------------------------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"----------------------------------------------------------------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 =- runGetMaybe $- PskKeyExchangeModes . map PskKexMode <$> getWords8- extensionDecode _ = error "extensionDecode: PskKeyExchangeModes"----------------------------------------------------------------data PskIdentity = PskIdentity ByteString Word32 deriving (Eq, Show)--data PreSharedKey- = PreSharedKeyClientHello [PskIdentity] [ByteString]- | PreSharedKeyServerHello Int- deriving (Eq, Show)--instance Extension PreSharedKey where- extensionID _ = EID_PreSharedKey- extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do- putOpaque16 $ runPut (mapM_ putIdentity ids)- putOpaque16 $ runPut (mapM_ putBinder bds)- where- putIdentity (PskIdentity bs w) = do- putOpaque16 bs- putWord32 w- putBinder = putOpaque8- extensionEncode (PreSharedKeyServerHello w16) =- runPut $- putWord16 $- fromIntegral w16- extensionDecode MsgTServerHello =- runGetMaybe $- PreSharedKeyServerHello . fromIntegral <$> getWord16- extensionDecode MsgTClientHello = runGetMaybe $ do- len1 <- fromIntegral <$> getWord16- identities <- getList len1 getIdentity- len2 <- fromIntegral <$> getWord16- binders <- getList len2 getBinder- return $ PreSharedKeyClientHello identities binders- where- getIdentity = do- identity <- getOpaque16- age <- getWord32- let len = 2 + B.length identity + 4- return (len, PskIdentity identity age)- getBinder = do- l <- fromIntegral <$> getWord8- binder <- getBytes l- let len = l + 1- return (len, binder)- extensionDecode _ = error "extensionDecode: PreShareKey"----------------------------------------------------------------newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32)- deriving (Eq, Show)--instance Extension EarlyDataIndication where- extensionID _ = EID_EarlyData- extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty- extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32- extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing)- extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing)- extensionDecode MsgTNewSessionTicket =- runGetMaybe $- EarlyDataIndication . Just <$> getWord32- extensionDecode _ = error "extensionDecode: EarlyDataIndication"----------------------------------------------------------------newtype Cookie = Cookie ByteString deriving (Eq, Show)--instance Extension Cookie where- extensionID _ = EID_Cookie- extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque- extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)- extensionDecode _ = error "extensionDecode: Cookie"----------------------------------------------------------------newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName]- deriving (Eq, Show)--instance Extension CertificateAuthorities where- extensionID _ = EID_CertificateAuthorities- extensionEncode (CertificateAuthorities names) =- runPut $- putDNames names- extensionDecode MsgTClientHello =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode MsgTCertificateRequest =- runGetMaybe (CertificateAuthorities <$> getDNames)- extensionDecode _ = error "extensionDecode: CertificateAuthorities"+{-# LANGUAGE RecordWildCards #-}++-- | Basic extensions are defined in RFC 6066+module Network.TLS.Extension (+ -- * 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_CompressCertificate,+ EID_RecordSizeLimit,+ 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_EchOuterExtensions,+ EID_EncryptedClientHello,+ EID_SecureRenegotiation+ ),+ definedExtensions,+ supportedExtensions,++ -- * Extension raw+ ExtensionRaw (..),+ toExtensionRaw,+ extensionLookup,+ lookupAndDecode,+ lookupAndDecodeAndDo,++ -- * Class+ Extension (..),++ -- * Extensions+ ServerNameType (..),+ ServerName (..),+ MaxFragmentLength (..),+ MaxFragmentEnum (..),+ SecureRenegotiation (..),+ ApplicationLayerProtocolNegotiation (..),+ ExtendedMainSecret (..),+ CertificateCompressionAlgorithm (.., CCA_Zlib, CCA_Brotli, CCA_Zstd),+ CompressCertificate (..),+ SupportedGroups (..),+ Group (..),+ EcPointFormatsSupported (..),+ EcPointFormat (+ EcPointFormat,+ EcPointFormat_Uncompressed,+ EcPointFormat_AnsiX962_compressed_prime,+ EcPointFormat_AnsiX962_compressed_char2+ ),+ RecordSizeLimit (..),+ SessionTicket (..),+ HeartBeat (..),+ HeartBeatMode (+ HeartBeatMode,+ HeartBeat_PeerAllowedToSend,+ HeartBeat_PeerNotAllowedToSend+ ),+ SignatureAlgorithms (..),+ SignatureAlgorithmsCert (..),+ SupportedVersions (..),+ KeyShare (..),+ KeyShareEntry (..),+ MessageType (..),+ PostHandshakeAuth (..),+ PskKexMode (PskKexMode, PSK_KE, PSK_DHE_KE),+ PskKeyExchangeModes (..),+ PskIdentity (..),+ PreSharedKey (..),+ EarlyDataIndication (..),+ Cookie (..),+ CertificateAuthorities (..),+ EchOuterExtensions (..),+ EncryptedClientHello (..),+) where++import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.X509 (DistinguishedName)++import Network.TLS.ECH.Config++import Network.TLS.Crypto.Types+import Network.TLS.Error+import Network.TLS.HashAndSignature+import Network.TLS.Imports+import Network.TLS.Packet (+ getBinaryVersion,+ getDNames,+ getSignatureHashAlgorithm,+ putBinaryVersion,+ putDNames,+ putSignatureHashAlgorithm,+ )+import Network.TLS.Types (HostName, Ticket, Version)+import Network.TLS.Wire++----------------------------------------------------------------+-- Extension identifiers++-- | Identifier of a TLS extension.+-- <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>+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_CompressCertificate :: ExtensionID -- RFC8879+pattern EID_CompressCertificate = ExtensionID 0x1b+pattern EID_RecordSizeLimit :: ExtensionID -- RFC8449+pattern EID_RecordSizeLimit = ExtensionID 0x1c+pattern EID_SessionTicket :: ExtensionID -- RFC4507+pattern EID_SessionTicket = ExtensionID 0x23+pattern EID_PreSharedKey :: ExtensionID -- RFC8446+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_EchOuterExtensions :: ExtensionID -- draft+pattern EID_EchOuterExtensions = ExtensionID 0xfd00+pattern EID_EncryptedClientHello :: ExtensionID -- draft+pattern EID_EncryptedClientHello = ExtensionID 0xfe0d+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_CompressCertificate = "CompressCertificate"+ show EID_RecordSizeLimit = "RecordSizeLimit"+ 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_EchOuterExtensions = "EchOuterExtensions"+ show EID_EncryptedClientHello = "EncryptedClientHello"+ show EID_SecureRenegotiation = "SecureRenegotiation"+ show (ExtensionID x) = "ExtensionID " ++ show x+{- FOURMOLU_ENABLE -}++------------------------------------------------------------++definedExtensions :: [ExtensionID]+definedExtensions =+ [ 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_CompressCertificate+ , EID_RecordSizeLimit+ , 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_EchOuterExtensions+ , EID_EncryptedClientHello+ , EID_SecureRenegotiation+ ]++-- | all supported extensions by the implementation+{- FOURMOLU_DISABLE -}+supportedExtensions :: [ExtensionID]+supportedExtensions =+ [ EID_ServerName -- 0x00+ , EID_SupportedGroups -- 0x0a+ , EID_EcPointFormats -- 0x0b+ , EID_SignatureAlgorithms -- 0x0d+ , EID_ApplicationLayerProtocolNegotiation -- 0x10+ , EID_ExtendedMainSecret -- 0x17+ , EID_CompressCertificate -- 0x1b+ , EID_RecordSizeLimit -- 0x1c+ , 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_EchOuterExtensions -- 0xfd00+ , EID_EncryptedClientHello -- 0xfe0d+ , 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_CompressCertificate bs) = showExtensionRaw eid bs decodeCompressCertificate+ show (ExtensionRaw eid@EID_RecordSizeLimit bs) = showExtensionRaw eid bs decodeRecordSizeLimit+ show (ExtensionRaw eid@EID_SessionTicket bs) = showExtensionRaw eid bs decodeSessionTicket+ show (ExtensionRaw eid@EID_PreSharedKey bs) = showExtensionRaw eid bs decodePreSharedKey+ show (ExtensionRaw eid@EID_EarlyData _) = show eid+ show (ExtensionRaw eid@EID_SupportedVersions bs) = showExtensionRaw eid bs decodeSupportedVersions+ show (ExtensionRaw eid@EID_Cookie bs) = show eid ++ " " ++ showBytesHex bs+ show (ExtensionRaw eid@EID_PskKeyExchangeModes bs) = showExtensionRaw eid bs decodePskKeyExchangeModes+ show (ExtensionRaw eid@EID_CertificateAuthorities bs) = showExtensionRaw eid bs decodeCertificateAuthorities+ show (ExtensionRaw eid@EID_PostHandshakeAuth _) = show eid+ show (ExtensionRaw eid@EID_SignatureAlgorithmsCert bs) = showExtensionRaw eid bs decodeSignatureAlgorithmsCert+ show (ExtensionRaw eid@EID_KeyShare bs) = showExtensionRaw eid bs decodeKeyShare+ show (ExtensionRaw eid@EID_EchOuterExtensions bs) = showExtensionRaw eid bs decodeEchOuterExtensions+ show (ExtensionRaw eid@EID_EncryptedClientHello bs) = showExtensionRaw eid bs decodeECH+ 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+ | MsgTHelloRetryRequest+ | MsgTEncryptedExtensions+ | MsgTNewSessionTicket+ | MsgTCertificateRequest+ deriving (Eq, Show)++------------------------------------------------------------++-- | Server Name extension including the name type and the associated name.+-- the associated name decoding is dependent of its name type.+-- name type = 0 : hostname+newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq)++data ServerNameType+ = ServerNameHostName HostName+ | ServerNameOther (Word8, ByteString)+ 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+ encodeNameType (ServerNameOther (nt, opaque)) = putWord8 nt >> putBytes opaque+ extensionDecode MsgTClientHello = decodeServerName+ extensionDecode MsgTServerHello = decodeServerName+ extensionDecode MsgTEncryptedExtensions = decodeServerName+ extensionDecode _ = error "extensionDecode: ServerName"++decodeServerName :: ByteString -> Maybe ServerName+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+ let sname = B.copy snameParsed+ name = case ty of+ 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion+ _ -> ServerNameOther (ty, sname)+ return (1 + 2 + B.length sname, name)++------------------------------------------------------------++-- | Max fragment extension with length from 512 bytes to 4096 bytes+--+-- RFC 6066 defines:+-- If a server receives a maximum fragment length negotiation request+-- for a value other than the allowed values, it MUST abort the+-- handshake with an "illegal_parameter" alert.+--+-- So, if a server receives MaxFragmentLengthOther, it must send the alert.+data MaxFragmentLength+ = MaxFragmentLength MaxFragmentEnum+ | MaxFragmentLengthOther Word8+ deriving (Show, Eq)++data MaxFragmentEnum+ = MaxFragment512+ | MaxFragment1024+ | MaxFragment2048+ | MaxFragment4096+ deriving (Show, Eq)++instance Extension MaxFragmentLength where+ extensionID _ = EID_MaxFragmentLength+ extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l+ where+ fromMaxFragmentEnum MaxFragment512 = 1+ fromMaxFragmentEnum MaxFragment1024 = 2+ fromMaxFragmentEnum MaxFragment2048 = 3+ fromMaxFragmentEnum MaxFragment4096 = 4+ extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l+ extensionDecode MsgTClientHello = decodeMaxFragmentLength+ extensionDecode MsgTServerHello = decodeMaxFragmentLength+ extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength+ extensionDecode _ = error "extensionDecode: MaxFragmentLength"++decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength+decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8+ where+ toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512+ toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024+ toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048+ toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096+ toMaxFragmentEnum n = MaxFragmentLengthOther n++------------------------------------------------------------++newtype SupportedGroups = SupportedGroups [Group] deriving (Show, Eq)++-- on decode, filter all unknown curves+instance Extension SupportedGroups where+ extensionID _ = EID_SupportedGroups+ extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups+ extensionDecode MsgTClientHello = decodeSupportedGroups+ extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups+ extensionDecode _ = error "extensionDecode: SupportedGroups"++decodeSupportedGroups :: ByteString -> Maybe SupportedGroups+decodeSupportedGroups =+ runGetMaybe (SupportedGroups . map Group <$> getWords16)++------------------------------------------------------------++newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]+ deriving (Show, Eq)++newtype EcPointFormat = EcPointFormat {fromEcPointFormat :: Word8}+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern EcPointFormat_Uncompressed :: EcPointFormat+pattern EcPointFormat_Uncompressed = EcPointFormat 0+pattern EcPointFormat_AnsiX962_compressed_prime :: EcPointFormat+pattern EcPointFormat_AnsiX962_compressed_prime = EcPointFormat 1+pattern EcPointFormat_AnsiX962_compressed_char2 :: EcPointFormat+pattern EcPointFormat_AnsiX962_compressed_char2 = EcPointFormat 2++instance Show EcPointFormat where+ show EcPointFormat_Uncompressed = "EcPointFormat_Uncompressed"+ show EcPointFormat_AnsiX962_compressed_prime = "EcPointFormat_AnsiX962_compressed_prime"+ show EcPointFormat_AnsiX962_compressed_char2 = "EcPointFormat_AnsiX962_compressed_char2"+ show (EcPointFormat x) = "EcPointFormat " ++ show x+{- FOURMOLU_ENABLE -}++-- on decode, filter all unknown formats+instance Extension EcPointFormatsSupported where+ extensionID _ = EID_EcPointFormats+ extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats+ extensionDecode MsgTClientHello = decodeEcPointFormatsSupported+ extensionDecode MsgTServerHello = decodeEcPointFormatsSupported+ extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"++decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported+decodeEcPointFormatsSupported =+ runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8)++------------------------------------------------------------++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"+ when (null sas) $ fail "signature algorithms are empty"+ return $ SignatureAlgorithms sas++------------------------------------------------------------++newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq)++newtype HeartBeatMode = HeartBeatMode {fromHeartBeatMode :: Word8}+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern HeartBeat_PeerAllowedToSend :: HeartBeatMode+pattern HeartBeat_PeerAllowedToSend = HeartBeatMode 1+pattern HeartBeat_PeerNotAllowedToSend :: HeartBeatMode+pattern HeartBeat_PeerNotAllowedToSend = HeartBeatMode 2++instance Show HeartBeatMode where+ show HeartBeat_PeerAllowedToSend = "HeartBeat_PeerAllowedToSend"+ show HeartBeat_PeerNotAllowedToSend = "HeartBeat_PeerNotAllowedToSend"+ show (HeartBeatMode x) = "HeartBeatMode " ++ show x+{- FOURMOLU_ENABLE -}++instance Extension HeartBeat where+ extensionID _ = EID_Heartbeat+ extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode+ extensionDecode MsgTClientHello = decodeHeartBeat+ extensionDecode MsgTServerHello = decodeHeartBeat+ extensionDecode _ = error "extensionDecode: HeartBeat"++decodeHeartBeat :: ByteString -> Maybe HeartBeat+decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8++------------------------------------------------------------++-- | 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 CertificateCompressionAlgorithm+ = CertificateCompressionAlgorithm Word16+ deriving (Eq)++{- FOURMOLU_DISABLE -}+pattern CCA_Zlib :: CertificateCompressionAlgorithm+pattern CCA_Zlib = CertificateCompressionAlgorithm 1+pattern CCA_Brotli :: CertificateCompressionAlgorithm+pattern CCA_Brotli = CertificateCompressionAlgorithm 2+pattern CCA_Zstd :: CertificateCompressionAlgorithm+pattern CCA_Zstd = CertificateCompressionAlgorithm 3++instance Show CertificateCompressionAlgorithm where+ show CCA_Zlib = "zlib"+ show CCA_Brotli = "brotli"+ show CCA_Zstd = "zstd"+ show (CertificateCompressionAlgorithm n) = "CertificateCompressionAlgorithm " ++ show n+{- FOURMOLU_ENABLE -}++newtype CompressCertificate = CompressCertificate [CertificateCompressionAlgorithm]+ deriving (Show, Eq)++instance Extension CompressCertificate where+ extensionID _ = EID_CompressCertificate+ extensionEncode (CompressCertificate cs) = runPut $ do+ putWord8 $ fromIntegral (length cs * 2)+ mapM_ putCCA cs+ where+ putCCA (CertificateCompressionAlgorithm n) = putWord16 n+ extensionDecode _ = decodeCompressCertificate++decodeCompressCertificate :: ByteString -> Maybe CompressCertificate+decodeCompressCertificate = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ cs <- getList len getCCA+ when (null cs) $ fail "empty list of CertificateCompressionAlgorithm"+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeCompressCertificate: broken length"+ return $ CompressCertificate cs+ where+ getCCA = do+ cca <- CertificateCompressionAlgorithm <$> getWord16+ return (2, cca)++------------------------------------------------------------++newtype RecordSizeLimit = RecordSizeLimit Word16 deriving (Eq, Show)++instance Extension RecordSizeLimit where+ extensionID _ = EID_RecordSizeLimit+ extensionEncode (RecordSizeLimit n) = runPut $ putWord16 n+ extensionDecode _ = decodeRecordSizeLimit++decodeRecordSizeLimit :: ByteString -> Maybe RecordSizeLimit+decodeRecordSizeLimit = runGetMaybe $ do+ r <- RecordSizeLimit <$> getWord16+ leftoverLen <- remaining+ when (leftoverLen /= 0) $ fail "decodeRecordSizeLimit: broken length"+ return r++------------------------------------------------------------++newtype SessionTicket = SessionTicket Ticket+ deriving (Show, Eq)++-- 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"++decodeSessionTicket :: ByteString -> Maybe SessionTicket+decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)++------------------------------------------------------------++data PskIdentity = PskIdentity ByteString Word32 deriving (Eq)++instance Show PskIdentity where+ show (PskIdentity bs n) = "PskId " ++ showBytesHex bs ++ " " ++ show n++data PreSharedKey+ = PreSharedKeyClientHello [PskIdentity] [ByteString]+ | PreSharedKeyServerHello Int+ deriving (Eq)++instance Show PreSharedKey where+ show (PreSharedKeyClientHello ids bndrs) =+ "PreSharedKey "+ ++ show ids+ ++ " "+ ++ "["+ ++ intercalate ", " (map showBytesHex bndrs)+ ++ "]"+ show (PreSharedKeyServerHello n) = "PreSharedKey " ++ show n++instance Extension PreSharedKey where+ extensionID _ = EID_PreSharedKey+ extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do+ putOpaque16 $ runPut (mapM_ putIdentity ids)+ putOpaque16 $ runPut (mapM_ putBinder bds)+ where+ putIdentity (PskIdentity bs w) = do+ putOpaque16 bs+ putWord32 w+ putBinder = putOpaque8+ extensionEncode (PreSharedKeyServerHello w16) =+ runPut $+ putWord16 $+ fromIntegral w16+ extensionDecode MsgTClientHello = decodePreSharedKeyClientHello+ extensionDecode MsgTServerHello = decodePreSharedKeyServerHello+ extensionDecode _ = error "extensionDecode: PreShareKey"++decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyClientHello = runGetMaybe $ do+ len1 <- fromIntegral <$> getWord16+ identities <- getList len1 getIdentity+ len2 <- fromIntegral <$> getWord16+ binders <- getList len2 getBinder+ return $ PreSharedKeyClientHello identities binders+ where+ getIdentity = do+ identity <- getOpaque16+ age <- getWord32+ let len = 2 + B.length identity + 4+ return (len, PskIdentity identity age)+ getBinder = do+ l <- fromIntegral <$> getWord8+ binder <- getBytes l+ let len = l + 1+ return (len, binder)++decodePreSharedKeyServerHello :: ByteString -> Maybe PreSharedKey+decodePreSharedKeyServerHello =+ runGetMaybe $+ PreSharedKeyServerHello . fromIntegral <$> getWord16++decodePreSharedKey :: ByteString -> Maybe PreSharedKey+decodePreSharedKey bs =+ decodePreSharedKeyClientHello bs+ <|> decodePreSharedKeyServerHello bs++------------------------------------------------------------++newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32)+ deriving (Eq, Show)++instance Extension EarlyDataIndication where+ extensionID _ = EID_EarlyData+ extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty+ extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32+ extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing)+ extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing)+ extensionDecode MsgTNewSessionTicket =+ runGetMaybe $+ EarlyDataIndication . Just <$> getWord32+ extensionDecode _ = error "extensionDecode: EarlyDataIndication"++------------------------------------------------------------++data SupportedVersions+ = SupportedVersionsClientHello [Version]+ | SupportedVersionsServerHello Version+ deriving (Eq)++instance Show SupportedVersions where+ show (SupportedVersionsClientHello vers) = "Versions " ++ show vers+ show (SupportedVersionsServerHello ver) = "Versions " ++ show ver++instance Extension SupportedVersions where+ extensionID _ = EID_SupportedVersions+ extensionEncode (SupportedVersionsClientHello vers) = runPut $ do+ putWord8 (fromIntegral (length vers * 2))+ mapM_ putBinaryVersion vers+ extensionEncode (SupportedVersionsServerHello ver) =+ runPut $+ putBinaryVersion ver+ extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello+ extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello+ extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"++decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ SupportedVersionsClientHello <$> getList len getVer+ where+ getVer = do+ ver <- getBinaryVersion+ return (2, ver)++decodeSupportedVersionsServerHello :: ByteString -> Maybe SupportedVersions+decodeSupportedVersionsServerHello =+ runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion)++decodeSupportedVersions :: ByteString -> Maybe SupportedVersions+decodeSupportedVersions bs =+ decodeSupportedVersionsClientHello bs+ <|> decodeSupportedVersionsServerHello bs++------------------------------------------------------------++newtype Cookie = Cookie ByteString deriving (Eq, Show)++instance Extension Cookie where+ extensionID _ = EID_Cookie+ extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque+ extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)+ extensionDecode _ = error "extensionDecode: Cookie"++------------------------------------------------------------++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)++instance Extension CertificateAuthorities where+ extensionID _ = EID_CertificateAuthorities+ extensionEncode (CertificateAuthorities names) =+ runPut $+ putDNames names+ 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 (Eq)++instance Show KeyShareEntry where+ show kse = show $ keyShareEntryGroup kse++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 (Eq)++{- FOURMOLU_DISABLE -}+instance Show KeyShare where+ show (KeyShareClientHello kses) = "KeyShare " ++ show kses+ show (KeyShareServerHello kse) = "KeyShare " ++ show kse+ show (KeyShareHRR g) = "KeyShareHRR " ++ show g+{- FOURMOLU_ENABLE -}++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 MsgTClientHello = decodeKeyShareClientHello+ extensionDecode MsgTServerHello = decodeKeyShareServerHello+ extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR+ extensionDecode _ = error "extensionDecode: KeyShare"++decodeKeyShareClientHello :: ByteString -> Maybe KeyShare+decodeKeyShareClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord16+ -- len == 0 allows for HRR+ grps <- getList len getKeyShareEntry+ return $ KeyShareClientHello $ catMaybes grps++decodeKeyShareServerHello :: ByteString -> Maybe KeyShare+decodeKeyShareServerHello = runGetMaybe $ do+ (_, ment) <- getKeyShareEntry+ case ment of+ Nothing -> fail "decoding KeyShare for ServerHello"+ Just ent -> return $ KeyShareServerHello ent++decodeKeyShareHRR :: ByteString -> Maybe KeyShare+decodeKeyShareHRR =+ runGetMaybe $+ KeyShareHRR . Group <$> getWord16++decodeKeyShare :: ByteString -> Maybe KeyShare+decodeKeyShare bs =+ decodeKeyShareClientHello bs+ <|> decodeKeyShareServerHello bs+ <|> decodeKeyShareHRR bs++------------------------------------------------------------++newtype EchOuterExtensions = EchOuterExtensions [ExtensionID]+ deriving (Eq, Show)++instance Extension EchOuterExtensions where+ extensionID _ = EID_EchOuterExtensions+ extensionEncode (EchOuterExtensions ids) = runPut $ do+ putWord8 $ fromIntegral (length ids * 2)+ mapM_ (putWord16 . fromExtensionID) ids+ extensionDecode MsgTClientHello = decodeEchOuterExtensions+ extensionDecode _ = error "extensionDecode: EchOuterExtensions"++decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions+decodeEchOuterExtensions = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ eids <- getList len $ do+ eid <- ExtensionID <$> getWord16+ return (2, eid)+ return $ EchOuterExtensions eids++------------------------------------------------------------++-- | Encrypted Client Hello+data EncryptedClientHello+ = ECHClientHelloInner+ | ECHClientHelloOuter+ { echCipherSuite :: (KDF_ID, AEAD_ID)+ , echConfigId :: ConfigId+ , echEnc :: EncodedPublicKey+ , echPayload :: ByteString+ }+ | ECHEncryptedExtensions ECHConfigList+ | ECHHelloRetryRequest ByteString+ deriving (Eq)++instance Show EncryptedClientHello where+ show ECHClientHelloInner = "ECHClientHelloInner"+ show ECHClientHelloOuter{..} =+ "ECHClientHelloOuter {"+ ++ show (fst echCipherSuite)+ ++ " "+ ++ show (snd echCipherSuite)+ ++ " "+ ++ show echConfigId+ ++ " "+ ++ showBytesHex enc+ ++ " "+ ++ showBytesHex echPayload+ ++ "}"+ where+ EncodedPublicKey enc = echEnc+ show (ECHEncryptedExtensions cnflst) = "ECHEncryptedExtensions " ++ show cnflst+ show (ECHHelloRetryRequest cnfm) = "ECHHelloRetryRequest " ++ showBytesHex cnfm++instance Extension EncryptedClientHello where+ extensionID _ = EID_EncryptedClientHello+ extensionEncode ECHClientHelloInner = runPut $ putWord8 1+ extensionEncode ECHClientHelloOuter{..} = runPut $ do+ putWord8 0+ let (kdfid, aeadid) = echCipherSuite+ putWord16 $ fromKDF_ID kdfid+ putWord16 $ fromAEAD_ID aeadid+ putWord8 echConfigId+ let EncodedPublicKey enc = echEnc+ putOpaque16 enc+ putOpaque16 echPayload+ extensionEncode (ECHEncryptedExtensions cnflist) = encodeECHConfigList cnflist+ extensionEncode (ECHHelloRetryRequest cnfm) = runPut $ putBytes cnfm+ extensionDecode MsgTClientHello = decodeECHClientHello+ extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions+ extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest+ extensionDecode _ = error "extensionDecode: EncryptedClientHello"++decodeECH :: ByteString -> Maybe EncryptedClientHello+decodeECH bs =+ decodeECHClientHello bs+ <|> decodeECHEncryptedExtensions bs+ <|> decodeECHHelloRetryRequest bs++decodeECHClientHello :: ByteString -> Maybe EncryptedClientHello+decodeECHClientHello = runGetMaybe $ do+ typ <- getWord8+ if typ == 1+ then return ECHClientHelloInner+ else do+ kdfid <- KDF_ID <$> getWord16+ aeadid <- AEAD_ID <$> getWord16+ cnfid <- getWord8+ enc <- EncodedPublicKey <$> getOpaque16+ payload <- getOpaque16+ return $+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfid+ , echEnc = enc+ , echPayload = payload+ }++decodeECHEncryptedExtensions :: ByteString -> Maybe EncryptedClientHello+decodeECHEncryptedExtensions bs =+ ECHEncryptedExtensions <$> decodeECHConfigList bs++decodeECHHelloRetryRequest :: ByteString -> Maybe EncryptedClientHello+decodeECHHelloRetryRequest = runGetMaybe $ do+ ECHHelloRetryRequest <$> getBytes 8++------------------------------------------------------------++-- | 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"
+ Network/TLS/Extension.hs-boot view
@@ -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}
Network/TLS/Extra/Cipher.hs view
@@ -1,191 +1,89 @@ module Network.TLS.Extra.Cipher (- -- * cipher suite+ -- * Cipher suite ciphersuite_default, ciphersuite_default_det, ciphersuite_all, ciphersuite_all_det, ciphersuite_strong, ciphersuite_strong_det,+ ciphersuite_dhe_rsa, - -- * individual ciphers- cipher_ECDHE_RSA_AES128GCM_SHA256,- cipher_ECDHE_RSA_AES256GCM_SHA384,- cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256,- cipher_ECDHE_ECDSA_AES128CCM_SHA256,- cipher_ECDHE_ECDSA_AES128CCM8_SHA256,- cipher_ECDHE_ECDSA_AES128GCM_SHA256,- cipher_ECDHE_ECDSA_AES256CCM_SHA256,- cipher_ECDHE_ECDSA_AES256CCM8_SHA256,- cipher_ECDHE_ECDSA_AES256GCM_SHA384,- cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256,- -- TLS 1.3+ -- * 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,++ -- ** RFC 8446 cipher_TLS13_AES128GCM_SHA256, cipher_TLS13_AES256GCM_SHA384, cipher_TLS13_CHACHA20POLY1305_SHA256, cipher_TLS13_AES128CCM_SHA256, cipher_TLS13_AES128CCM8_SHA256,-) where -import qualified Data.ByteString as B+ -- ** RFC 5289+ cipher_ECDHE_ECDSA_AES128GCM_SHA256,+ cipher_ECDHE_ECDSA_AES256GCM_SHA384,+ cipher_ECDHE_RSA_AES128GCM_SHA256,+ cipher_ECDHE_RSA_AES256GCM_SHA384, -import Data.Tuple (swap)-import Network.TLS.Cipher-import Network.TLS.Types (Version (..))+ -- ** RFC 7251+ cipher_ECDHE_ECDSA_AES128CCM_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM_SHA256,+ cipher_ECDHE_ECDSA_AES128CCM8_SHA256,+ cipher_ECDHE_ECDSA_AES256CCM8_SHA256, + -- ** RFC 7905+ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256,+ cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256,+ cipher_DHE_RSA_CHACHA20POLY1305_SHA256,+) where+ import Crypto.Cipher.AES import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.System.CPU--------------------------------------------------------------------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+import qualified Data.ByteString as B+import Data.Tuple (swap) -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)- )+import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types ---------------------------------------------------------------- -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@@ -196,30 +94,12 @@ -- hardware-acceleration support. If this dynamic runtime behavior is not -- desired, use 'ciphersuite_default_det' instead. ciphersuite_default :: [Cipher]-ciphersuite_default = sortOptimized sets_default+ciphersuite_default = ciphersuite_strong -- | Same as 'ciphersuite_default', but using deterministic preference not -- influenced by the CPU. ciphersuite_default_det :: [Cipher]-ciphersuite_default_det = sortDeterministic sets_default--sets_default :: [CipherSet]-sets_default =- [ -- First the PFS + GCM + SHA2 ciphers- SetAead- [cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384]- [cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256]- [cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256]- , SetAead- [cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384]- [cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256]- []- , -- TLS13 (listed at the end but version is negotiated first)- SetAead- [cipher_TLS13_AES128GCM_SHA256, cipher_TLS13_AES256GCM_SHA384]- [cipher_TLS13_CHACHA20POLY1305_SHA256]- [cipher_TLS13_AES128CCM_SHA256]- ]+ciphersuite_default_det = ciphersuite_strong_det ---------------------------------------------------------------- @@ -238,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@@ -262,141 +142,98 @@ 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] ] -------------------------------------------------------------------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- }+-- | DHE-RSA cipher suite. This only includes ciphers bound specifically to+-- DHE-RSA so TLS 1.3 ciphers must be added separately.+--+-- @since 2.1.5+ciphersuite_dhe_rsa :: [Cipher]+ciphersuite_dhe_rsa =+ [ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384+ , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+ , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+ ] -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- }+-- A list of cipher suite is found from:+-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 -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- }+----------------------------------------------------------------+-- RFC 5288 -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+-- 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"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } -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- }+{-# 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 -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+-- 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"+ , cipherBulk = bulk_aes256gcm+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 } --- 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:--- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4+{-# 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"@@ -407,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"@@ -419,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"@@ -431,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"@@ -443,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"@@ -455,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"@@ -470,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"@@ -482,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"@@ -494,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"@@ -506,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"@@ -521,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"@@ -533,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"@@ -545,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"@@ -557,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"@@ -572,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"@@ -583,3 +532,277 @@ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 }++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"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , 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 -> ByteString -> ByteString -> Int -> (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}
+ Network/TLS/Extra/CipherCBC.hs view
@@ -0,0 +1,201 @@+module Network.TLS.Extra.CipherCBC (+ -- * TLS 1.2 CBC ciphers with PFS and SHA2+ ciphersuite_pfs_sha2_cbc,+ ciphersuite_ecdhe_sha2_cbc,+ ciphersuite_dhe_rsa_sha2_cbc,++ -- ** Individual CBC ciphers+ cipher_DHE_RSA_AES128_SHA256,+ cipher_DHE_RSA_AES256_SHA256,+ cipher_ECDHE_RSA_AES128CBC_SHA256,+ cipher_ECDHE_RSA_AES256CBC_SHA384,+ cipher_ECDHE_ECDSA_AES128CBC_SHA256,+) where++import Crypto.Cipher.AES+import Crypto.Cipher.Types hiding (Cipher, cipherName)+import Crypto.Error+-- import Crypto.System.CPU+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types hiding (IV)++----------------------------------------------------------------++-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_pfs_sha2_cbc :: [Cipher]+ciphersuite_pfs_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES128_SHA256+ , cipher_DHE_RSA_AES256_SHA256+ ]++-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_ecdhe_sha2_cbc :: [Cipher]+ciphersuite_ecdhe_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ ]++-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a+-- SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_dhe_rsa_sha2_cbc :: [Cipher]+ciphersuite_dhe_rsa_sha2_cbc =+ [ cipher_DHE_RSA_AES256_SHA256+ , cipher_DHE_RSA_AES128_SHA256+ ]++----------------------------------------------------------------++-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES128_SHA256 :: Cipher+cipher_DHE_RSA_AES128_SHA256 =+ Cipher+ { cipherID = 0x0067+ , cipherName = "DHE-RSA-AES128-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES256_SHA256 :: Cipher+cipher_DHE_RSA_AES256_SHA256 =+ cipher_DHE_RSA_AES128_SHA256+ { cipherID = 0x006B+ , cipherName = "DHE-RSA-AES256-SHA256"+ , cipherBulk = bulk_aes256+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xC027+ , cipherName = "ECDHE-RSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_RSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC028+ , cipherName = "ECDHE-RSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xc023+ , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_ECDSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC024+ , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++----------------------------------------------------------------++aes128cbc :: BulkDirection -> BulkKey -> BulkBlock+aes128cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes128cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++aes256cbc :: BulkDirection -> BulkKey -> BulkBlock+aes256cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes256cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++makeIV_ :: BlockCipher a => B.ByteString -> IV a+makeIV_ = fromMaybe (error "makeIV_") . makeIV++takelast :: Int -> B.ByteString -> B.ByteString+takelast i b = B.drop (B.length b - i) b++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++----------------------------------------------------------------++bulk_aes128 :: Bulk+bulk_aes128 =+ Bulk+ { bulkName = "AES128"+ , bulkKeySize = 16+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes128cbc+ }++bulk_aes256 :: Bulk+bulk_aes256 =+ Bulk+ { bulkName = "AES256"+ , bulkKeySize = 32+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes256cbc+ }
Network/TLS/Handshake.hs view
@@ -8,11 +8,10 @@ ) where import Network.TLS.Context.Internal-import Network.TLS.Struct- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.Struct import Control.Monad.State.Strict @@ -26,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock.-handshakeWith :: MonadIO m => Context -> Handshake -> m ()-handshakeWith ctx hs =+handshakeWith :: MonadIO m => Context -> HandshakeR -> m ()+handshakeWith ctx hsr = liftIO $ withWriteLock ctx $ handleException ctx $- doHandshakeWith_ (ctxRoleParams ctx) ctx hs+ doHandshakeWith_ (ctxRoleParams ctx) ctx hsr
Network/TLS/Handshake/Certificate.hs view
@@ -3,13 +3,21 @@ badCertificate, rejectOnException, verifyLeafKeyUsage,+ verifyLeafKeyUsagePurpose, extractCAname, ) where import Control.Exception (SomeException) import Control.Monad (unless) import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet)+import Data.X509 (+ ExtExtendedKeyUsage (..),+ ExtKeyUsage (..),+ ExtKeyUsageFlag,+ ExtKeyUsagePurpose (..),+ extensionGet,+ )+ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509@@ -45,6 +53,19 @@ case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags++verifyLeafKeyUsagePurpose+ :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m ()+verifyLeafKeyUsagePurpose _ (CertificateChain []) = return ()+verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) =+ unless verified $+ badCertificate $+ "certificate is not allowed for " ++ show validPurpose+ where+ cert = getCertificate signed+ verified = case extensionGet (certExtensions cert) of+ Nothing -> True+ Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert
Network/TLS/Handshake/Client.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client ( handshakeClient,@@ -10,6 +11,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Client.ClientHello+import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello import Network.TLS.Handshake.Client.TLS12 import Network.TLS.Handshake.Client.TLS13@@ -25,8 +27,9 @@ ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()-handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx+handshakeClientWith+ :: ClientParams -> Context -> HandshakeR -> IO ()+handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ = throwCore $ Error_Protocol@@ -36,14 +39,35 @@ -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO ()-handshakeClient cparams ctx = handshake cparams ctx groups Nothing+handshakeClient cparams ctx = do+ grps <- case clientSessions cparams of+ [] ->+ return $+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = groupsSelected+ }+ (_, sdata) : _ -> case sessionGroup sdata of+ Nothing ->+ -- TLS 1.2 or earlier+ return $+ Groups+ { grpsSupported = groupsSupported -- for ciphers+ , grpsSelected = []+ }+ Just grp+ | grp `elem` groupsSupported -> do+ let supported = grp : filter (/= grp) groupsSupported+ return $+ Groups+ { grpsSupported = supported+ , grpsSelected = [grp]+ }+ | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect"+ handshake cparams ctx grps Nothing where groupsSupported = supportedGroups (ctxSupported ctx)- groups = case clientWantSessionResume cparams of- Nothing -> groupsSupported- Just (_, sdata) -> case sessionGroup sdata of- Nothing -> [] -- TLS 1.2 or earlier- Just grp -> grp : filter (/= grp) groupsSupported+ groupsSelected = onSelectKeyShareGroups (clientHooks cparams) groupsSupported -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a@@ -55,10 +79,10 @@ handshake :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> IO ()-handshake cparams ctx groups mparams = do+handshake cparams ctx grps@Groups{..} mparams = do -------------------------------- -- Sending ClientHello pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx@@ -66,21 +90,21 @@ let async = rtt0 && not (ctxQUICMode ctx) when async $ do chSentTime <- getCurrentTimeFromBase- asyncServerHello13 cparams ctx groupToSend chSentTime+ asyncServerHello13 cparams ctx grpsSelected chSentTime updateMeasure ctx incrementNbHandshakes- crand <- sendClientHello cparams ctx groups mparams pskinfo+ crand <-+ sendClientHello cparams ctx grps mparams pskinfo -------------------------------- -- Receiving ServerHello unless async $ do- (ver, hss, hrr) <- receiveServerHello cparams ctx mparams- --------------------------------+ (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of TLS13 | hrr ->- helloRetry cparams ctx mparams ver crand $ drop 1 groups+ helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected | otherwise -> do- recvServerSecondFlight13 cparams ctx groupToSend+ recvServerSecondFlight13 cparams ctx grpsSelected sendClientSecondFlight13 cparams ctx _ | rtt0 ->@@ -89,31 +113,9 @@ "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do- recvServerFirstFlight12 cparams ctx hss+ recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx- recvServerSecondFlight12 ctx- where- groupToSend = listToMaybe groups--receiveServerHello- :: ClientParams- -> Context- -> Maybe (ClientRandom, Session, Version)- -> IO (Version, [Handshake], Bool)-receiveServerHello cparams ctx mparams = do- chSentTime <- getCurrentTimeFromBase- hss <- recvServerHello cparams ctx- setRTT ctx chSentTime- ver <- usingState_ ctx getVersion- unless (maybe True (\(_, _, v) -> v == ver) mparams) $- throwCore $- Error_Protocol "version changed after hello retry" IllegalParameter- -- recvServerHello sets TLS13HRR according to the server random.- -- For 1st server hello, getTLS13HR returns True if it is HRR and- -- False otherwise. For 2nd server hello, getTLS13HR returns- -- False since it is NOT HRR.- hrr <- usingState_ ctx getTLS13HRR- return (ver, hss, hrr)+ recvServerSecondFlight12 cparams ctx ---------------------------------------------------------------- @@ -124,24 +126,46 @@ -> Version -> ClientRandom -> [Group]+ -> [Group] -> IO ()-helloRetry cparams ctx mparams ver crand groups = do- when (null groups) $+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do+ when (null groupsSupported) $ throwCore $- Error_Protocol "group is exhausted in the client side" IllegalParameter+ Error_Protocol "no supported groups on the client side" IllegalParameter when (isJust mparams) $ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)- | selectedGroup `elem` groups -> do+ -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups+ -- and MUST NOT already have been offered in the initial key_share.+ | selectedGroup `elem` groupsSupported+ && selectedGroup `notElem` groupsSelected -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxRecordState ctx let cparams' = cparams{clientUseEarlyData = False} runPacketFlight ctx $ sendChangeCipherSpec13 ctx clientSession <- tls13stSession <$> getTLS13State ctx- handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))+ -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical+ -- to the first except for the specific listed changes.+ -- supported_groups is NOT on that list, so it must be unchanged.+ let grps =+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = [selectedGroup]+ }++ handshake+ cparams'+ ctx+ grps+ (Just (crand, clientSession, ver))+ | selectedGroup `elem` groupsSelected ->+ throwCore $+ Error_Protocol+ "server selected a group already offered in key_share"+ IllegalParameter | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -1,12 +1,28 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo,+ Groups (..), ) where +import qualified Control.Exception as E+import Crypto.HPKE hiding (CipherText, PlainText)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Network.TLS.ECH.Config+import System.Random++#if !MIN_VERSION_random(1,3,0)+import Data.ByteString.Internal (unsafeCreate)+import Foreign.Ptr+import Foreign.Storable+#endif+ import Network.TLS.Cipher-import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension@@ -14,10 +30,10 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Packet hiding (getExtensions)@@ -28,16 +44,26 @@ ---------------------------------------------------------------- +data Groups = Groups+ { grpsSupported :: [Group]+ -- ^ For supported_group, head is identical to key_share+ , grpsSelected :: [Group]+ -- ^ For key_share+ }+ deriving (Eq, Show)++----------------------------------------------------------------+ sendClientHello :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> PreSharedKeyInfo -> IO ClientRandom-sendClientHello cparams ctx groups mparams pskinfo = do- crand <- generateClientHelloParams mparams- sendClientHello' cparams ctx groups crand pskinfo+sendClientHello cparams ctx grps mparams pskinfo = do+ crand <- generateClientHelloParams mparams -- Inner for ECH+ sendClientHello' cparams ctx grps crand pskinfo return crand where highestVer = maximum $ supportedVersions $ ctxSupported ctx@@ -51,9 +77,9 @@ return crand generateClientHelloParams Nothing = do crand <- clientRandom ctx- let paramSession = case clientWantSessionResume cparams of- Nothing -> Session Nothing- Just (sidOrTkt, sdata)+ let paramSession = case clientSessions cparams of+ [] -> Session Nothing+ (sidOrTkt, sdata) : _ | sessionVersion sdata >= TLS13 -> Session Nothing | ems == RequireEMS && noSessionEMS -> Session Nothing | isTicket sidOrTkt -> Session $ Just $ toSessionID sidOrTkt@@ -76,23 +102,75 @@ sendClientHello' :: ClientParams -> Context- -> [Group]+ -> Groups -> ClientRandom- -> PreSharedKeyInfo+ -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)+ , Maybe CipherChoice+ , Bool+ ) -> IO ()-sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do+sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer clientSession <- tls13stSession <$> getTLS13State ctx hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer- let cipherIds = map cipherID ciphers- compIds = map compressionID compressions- mkClientHello exts = ClientHello ver crand compIds $ CH clientSession cipherIds exts+ let cipherIds = map (CipherId . cipherID) ciphers+ mkClientHello exts =+ CH+ { chVersion = ver+ , chRandom = crand+ , chSession = clientSession+ , chCiphers = cipherIds+ , chComps = [0]+ , chExtensions = exts+ }+ setMyRecordLimit ctx $ limitRecordSize $ sharedLimit $ ctxShared ctx extensions0 <- catMaybes <$> getExtensions let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0- extensions <- adjustExtentions extensions1 $ mkClientHello extensions1- sendPacket12 ctx $ Handshake [mkClientHello extensions]+ extensions <- adjustPreSharedKeyExt extensions1 $ mkClientHello extensions1+ let ch0 = mkClientHello extensions+ updateTranscriptHashI ctx "ClientHelloI" $ encodeHandshake $ ClientHello ch0+ let nhpks = supportedHPKE $ clientSupported cparams+ echcnfs = sharedECHConfigList $ clientShared cparams+ mEchParams = lookupECHConfigList nhpks echcnfs+ ch <-+ if clientUseECH cparams+ then case mEchParams of+ Nothing -> do+ if hrr+ then do+ (chI, _) <- fromJust <$> usingHState ctx getClientHello+ let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)}+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' []+ return ch0'+ else do+ gEchExt <- greasingEchExt+ let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)}+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' []+ return ch0'+ Just echParams -> do+ let encoded = encodeHandshake $ ClientHello ch0+ usingHState ctx $ setClientHello ch0 [encoded]+ mcrandO <- usingHState ctx getOuterClientRandom+ crandO <- case mcrandO of+ Nothing -> clientRandom ctx+ Just x -> return x+ usingHState ctx $ do+ setClientRandom crandO+ setOuterClientRandom $ Just crandO+ mpskExt <- randomPreSharedKeyExt+ createEncryptedClientHello ctx ch0 echParams crandO mpskExt+ else do+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0 []+ return ch0+ sendPacket12 ctx $ Handshake [ClientHello ch] [] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info@@ -101,11 +179,9 @@ modifyTLS13State ctx $ \st -> st{tls13stSentExtensions = sentExtensions} where ciphers = supportedCiphers $ ctxSupported ctx- compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx- groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations@@ -117,46 +193,29 @@ -- (not always present) have length > 0. getExtensions = sequence- [ sniExtension- , secureReneg- , alpnExtension- , emsExtension- , groupExtension- , ecPointExtension- , sessionTicketExtension- , signatureAlgExtension- , -- , heartbeatExtension- versionExtension- , earlyDataExtension- , keyshareExtension- , cookieExtension- , postHandshakeAuthExtension- , pskExchangeModeExtension- , preSharedKeyExtension -- MUST be last (RFC 8446)+ [ {- 0xfe0d -} echExt+ , {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x0b -} ecPointExt+ , {- 0x0d -} signatureAlgExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1b -} compCertExt+ , {- 0x1c -} recordSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0x2a -} earlyDataExt+ , {- 0x2b -} versionExt+ , {- 0x2c -} cookieExt+ , {- 0x2d -} pskExchangeModeExt+ , {- 0x31 -} postHandshakeAuthExt+ , {- 0x33 -} keyShareExt+ , {- 0xff01 -} secureRenegExt+ , {- 0x29 -} preSharedKeyExt -- MUST be last (RFC 8446) ] - toExtensionRaw :: Extension e => e -> ExtensionRaw- toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)+ -------------------- - secureReneg =- if supportedSecureRenegotiation $ ctxSupported ctx- then do- cvd <- usingState_ ctx $ getVerifyData ClientRole- return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""- else return Nothing- alpnExtension = do- mprotos <- onSuggestALPN $ clientHooks cparams- case mprotos of- Nothing -> return Nothing- Just protos -> do- usingState_ ctx $ setClientALPNSuggest protos- return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos- emsExtension =- return $- if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)- then Nothing- else Just $ toExtensionRaw ExtendedMainSecret- sniExtension =+ sniExt = if clientUseServerNameIndication cparams then do let sni = fst $ clientServerIdentification cparams@@ -164,26 +223,18 @@ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - groupExtension =- return $- Just $- toExtensionRaw $- SupportedGroups (supportedGroups $ ctxSupported ctx)- ecPointExtension =+ -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond+ -- to a group offered in the "supported_groups" extension and MUST+ -- appear in the same order.+ groupExt = return $ Just $ toExtensionRaw $ SupportedGroups grpsSupported++ ecPointExt = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]- -- [EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]- -- heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend - sessionTicketExtension = do- case clientWantSessionResume cparams of- Just (sidOrTkt, _)- | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt- _ -> return $ Just $ toExtensionRaw $ SessionTicket ""-- signatureAlgExtension =+ signatureAlgExt = return $ Just $ toExtensionRaw $@@ -191,74 +242,139 @@ supportedHashSignatures $ clientSupported cparams - versionExtension- | tls13 = do- let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx- return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers- | otherwise = return Nothing-- -- FIXME- keyshareExtension- | tls13 = case groupToSend of+ alpnExt = do+ mprotos <- onSuggestALPN $ clientHooks cparams+ case mprotos of Nothing -> return Nothing- Just grp -> do- (cpri, ent) <- makeClientKeyShare ctx grp- usingHState ctx $ setGroupPrivate cpri- return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]- | otherwise = return Nothing+ Just protos -> do+ usingState_ ctx $ setClientALPNSuggest protos+ return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos - preSharedKeyExtension =- case pskInfo of- Nothing -> return Nothing- Just (identity, _, choice, obfAge) ->- let zero = cZero choice- pskIdentity = PskIdentity identity obfAge- offeredPsks = PreSharedKeyClientHello [pskIdentity] [zero]- in return $ Just $ toExtensionRaw offeredPsks+ emsExt =+ return $+ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx)+ then Nothing+ else Just $ toExtensionRaw ExtendedMainSecret - pskExchangeModeExtension- | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]- | otherwise = return Nothing+ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib]) - earlyDataExtension+ recordSizeLimitExt = case limitRecordSize $ sharedLimit $ ctxShared ctx of+ Nothing -> return Nothing+ Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz++ sessionTicketExt =+ case clientSessions cparams of+ (sidOrTkt, _) : _+ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt+ _ | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket ""+ | otherwise -> return $ Nothing++ earlyDataExt | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) | otherwise = return Nothing - cookieExtension = do+ versionExt+ | clientUseECH cparams = do+ let vers = supportedVersions $ ctxSupported ctx+ if TLS13 `elem` vers+ then+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello [TLS13]+ else+ throwCore $ Error_Misc "TLS 1.3 must be specified for Encrypted Client Hello"+ | tls13 = do+ let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers+ | otherwise = return Nothing++ cookieExt = do mcookie <- usingState_ ctx getTLS13Cookie case mcookie of Nothing -> return Nothing Just cookie -> return $ Just $ toExtensionRaw cookie - postHandshakeAuthExtension+ pskExchangeModeExt+ | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]+ | otherwise = return Nothing++ postHandshakeAuthExt | ctxQUICMode ctx = return Nothing | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing - adjustExtentions exts ch =+ keyShareExt+ | tls13 = do+ (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected+ usingHState ctx $ setGroupPrivate grpCpris+ return $ Just $ toExtensionRaw $ KeyShareClientHello ents+ | otherwise = return Nothing++ secureRenegExt =+ if supportedSecureRenegotiation $ ctxSupported ctx+ then do+ VerifyData cvd <- usingState_ ctx $ getVerifyData ClientRole+ return $ Just $ toExtensionRaw $ SecureRenegotiation cvd ""+ else return Nothing++ -- ECHClientHelloInner should be replaced if ECHConfigList is not available.+ echExt+ | clientUseECH cparams = return $ Just $ toExtensionRaw ECHClientHelloInner+ | otherwise = return Nothing++ preSharedKeyExt = case pskInfo of+ Nothing -> return Nothing+ Just (identities, _, choice, obfAge) -> do+ let zero = cZero choice+ pskIdentities = map (\x -> PskIdentity x obfAge) identities+ -- [zero] is a place holds.+ -- adjustPreSharedKeyExt will replace them.+ binders = replicate (length pskIdentities) $ convert zero+ offeredPsks = PreSharedKeyClientHello pskIdentities binders+ return $ Just $ toExtensionRaw offeredPsks++ randomPreSharedKeyExt :: IO (Maybe ExtensionRaw)+ randomPreSharedKeyExt =+ case pskInfo of+ Nothing -> return Nothing+ Just (identities, _, choice, _) -> do+ let zero = cZero choice+ zeroR <- getStdRandom $ uniformByteString $ BA.length zero+ obfAgeR <- getStdRandom genWord32+ let genPskId x = do+ xR <- getStdRandom $ uniformByteString $ B.length x+ return $ PskIdentity xR obfAgeR+ pskIdentitiesR <- mapM genPskId identities+ let bindersR = replicate (length pskIdentitiesR) zeroR+ offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR+ return $ Just $ toExtensionRaw offeredPsksR++ ----------------------------------------++ adjustPreSharedKeyExt exts ch =+ case pskInfo of Nothing -> return exts- Just (_, sdata, choice, _) -> do+ Just (identities, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret- let ech = encodeHandshake ch+ let ech = encodeHandshake $ ClientHello ch h = cHash choice- siz = hashDigestSize h- binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech)+ siz = (hashDigestSize h + 1) * length identities + 2+ binder = makePSKBinder earlySecret h siz ech+ -- PSK is shared by the previous TLS session.+ -- So, PSK is unique for identities.+ let binders = replicate (length identities) binder let exts' = init exts ++ [adjust (last exts)] adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders where- withBinders = replacePSKBinder withoutBinders binder+ withBinders = replacePSKBinder withoutBinders binders return exts' getEarlySecretInfo choice = do let usedCipher = cCipher choice usedHash = cHash choice Just earlySecret <- usingHState ctx getTLS13EarlySecret- -- Client hello is stored in hstHandshakeDigest- -- But HandshakeDigestContext is not created yet.- earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False+ earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) let clientEarlySecret = pairClient earlyKey unless (ctxQUICMode ctx) $ do runPacketFlight ctx $ sendChangeCipherSpec13 ctx@@ -271,7 +387,10 @@ ---------------------------------------------------------------- type PreSharedKeyInfo =- (Maybe (SessionID, SessionData, CipherChoice, Second), Maybe CipherChoice, Bool)+ ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second)+ , Maybe CipherChoice+ , Bool+ ) getPreSharedKeyInfo :: ClientParams@@ -286,31 +405,206 @@ ciphers = supportedCiphers $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13- sessionAndCipherToResume13 = do- guard tls13- (sid, sdata) <- clientWantSessionResume cparams- guard (sessionVersion sdata >= TLS13)- let cid = sessionCipher sdata- sCipher <- find (\c -> cipherID c == cid) ciphers- return (sid, sdata, sCipher) - getPskInfo =- case sessionAndCipherToResume13 of- Nothing -> return Nothing- Just (identity, sdata, sCipher) -> do- let tinfo = fromJust $ sessionTicketInfo sdata- age <- getAge tinfo- return $- if isAgeValid age tinfo- then- Just- ( identity- , sdata- , makeCipherChoice TLS13 sCipher- , ageToObfuscatedAge age tinfo- )- else Nothing+ sessions = case clientSessions cparams of+ [] -> Nothing+ (sid, sdata) : xs -> do+ guard tls13+ guard (sessionVersion sdata >= TLS13)+ let cid = sessionCipher sdata+ sids = map fst xs+ sCipher <- findCipher cid ciphers+ Just (sid : sids, sdata, sCipher) + getPskInfo = case sessions of+ Nothing -> return Nothing+ Just (identity, sdata, sCipher) -> do+ let tinfo = fromJust $ sessionTicketInfo sdata+ age <- getAge tinfo+ return $+ if isAgeValid age tinfo+ then+ Just+ ( identity+ , sdata+ , makeCipherChoice TLS13 sCipher+ , ageToObfuscatedAge age tinfo+ )+ else Nothing+ get0RTTinfo (_, sdata, choice, _) | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice | otherwise = Nothing++----------------------------------------------------------------++createEncryptedClientHello+ :: Context+ -> ClientHello+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> ClientRandom+ -> Maybe ExtensionRaw+ -> IO ClientHello+createEncryptedClientHello ctx ch0@CH{..} echParams@(kdfid, aeadid, conf) crO mpskExt = E.handle hpkeHandler $ do+ let (chExtsO, chExtsI) = dupCompExts (cnfPublicName conf) mpskExt chExtensions+ chI =+ ch0+ { chSession = Session Nothing+ , chExtensions = chExtsI+ }+ Just (func, enc, taglen) <- getHPKE ctx echParams+ let bsI = encodeHandshake' $ ClientHello chI+ padLen = 32 - (B.length bsI .&. 31)+ bsI' = bsI <> B.replicate padLen 0+ let outerZ =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = B.replicate (B.length bsI' + taglen) 0+ }+ echOZ = extensionEncode outerZ+ chExtsOTail = drop 1 chExtsO+ chOZ =+ ch0+ { chRandom = crO+ , chExtensions =+ ExtensionRaw EID_EncryptedClientHello echOZ : chExtsOTail+ }+ aad = encodeHandshake' $ ClientHello chOZ+ bsO <- func aad bsI'+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (kdfid, aeadid)+ , echConfigId = cnfConfigId conf+ , echEnc = enc+ , echPayload = bsO+ }+ echO = extensionEncode outer+ chO =+ chOZ+ { chExtensions =+ ExtensionRaw EID_EncryptedClientHello echO : chExtsOTail+ }+ return chO+ where+ hpkeHandler :: HPKEError -> IO ClientHello+ hpkeHandler _ = return ch0++dupCompExts+ :: HostName+ -> Maybe ExtensionRaw+ -> [ExtensionRaw]+ -> ([ExtensionRaw], [ExtensionRaw]) -- Outer, inner+dupCompExts host mpskExt chExts = step1 chExts+ where+ step1 (echExtI@(ExtensionRaw EID_EncryptedClientHello _) : exts) =+ (echExtO : os, echExtI : is)+ where+ echExtO = ExtensionRaw EID_EncryptedClientHello ""+ (os, is) = step2 exts+ step1 _ = error "step1"+ step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) =+ (sniExtO : os, sniExtI : is)+ where+ sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host]+ (os, is) = step3 exts id+ step2 _ = error "step2"+ step3 [] build = ([], [echOuterExt])+ where+ echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []+ step3 [pskExtI@(ExtensionRaw EID_PreSharedKey _)] build =+ ([pskExtO], [echOuterExt, pskExtI])+ where+ echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []+ pskExtO = fromJust mpskExt+ step3 (i@(ExtensionRaw eid _) : is) build = (i : os', is')+ where+ (os', is') = step3 is (build . (eid :))++getHPKE+ :: Context+ -> (KDF_ID, AEAD_ID, ECHConfig)+ -> IO (Maybe (AAD -> PlainText -> IO CipherText, EncodedPublicKey, Int))+getHPKE ctx (kdfid, aeadid, conf) = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let encodedConfig = encodeECHConfig conf+ info = "tls ech\x00" <> encodedConfig+ (pkSm, ctxS) <- setupBaseS kemid kdfid aeadid Nothing Nothing mpkR info+ let func = seal ctxS+ setTLS13HPKE ctx func 0+ return $ Just (func, pkSm, nT)+ Just (func, _) -> return $ Just (func, EncodedPublicKey "", nT)+ where+ mpkR = cnfEncodedPublicKey conf+ kemid = cnfKemId conf+ nT = nTag aeadid++----------------------------------------------------------------++lookupECHConfigList+ :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -> ECHConfigList+ -> Maybe (KDF_ID, AEAD_ID, ECHConfig)+lookupECHConfigList [] _ = Nothing+lookupECHConfigList ((kemid, kdfid, aeadid) : xs) cnfs =+ case find (\cnf -> cnfKemId cnf == kemid) cnfs of+ Nothing -> lookupECHConfigList xs cnfs+ Just cnf+ | (kdfid, aeadid) `elem` cnfCipherSuite cnf ->+ Just (kdfid, aeadid, cnf)+ | otherwise -> lookupECHConfigList xs cnfs++cnfKemId :: ECHConfig -> KEM_ID+cnfKemId ECHConfig{..} = KEM_ID $ kem_id $ key_config contents++cnfCipherSuite :: ECHConfig -> [(KDF_ID, AEAD_ID)]+cnfCipherSuite ECHConfig{..} = map conv $ cipher_suites $ key_config contents+ where+ conv HpkeSymmetricCipherSuite{..} = (KDF_ID kdf_id, AEAD_ID aead_id)++cnfEncodedPublicKey :: ECHConfig -> EncodedPublicKey+cnfEncodedPublicKey ECHConfig{..} = EncodedPublicKey pk+ where+ EncodedServerPublicKey pk = public_key $ key_config contents++cnfPublicName :: ECHConfig -> HostName+cnfPublicName ECHConfig{..} = public_name contents++cnfConfigId :: ECHConfig -> ConfigId+cnfConfigId ECHConfig{..} = config_id $ key_config contents++----------------------------------------------------------------++-- Pretending X25519 is used because it is the de-facto and+-- its public key is easily created.+greasingEchExt :: IO ExtensionRaw+greasingEchExt = do+ cid <- getStdRandom genWord8+ enc <- getStdRandom $ uniformByteString 32+ n <- getStdRandom $ randomR (4, 6)+ payload <- getStdRandom $ uniformByteString (n * 32 + 16)+ let outer =+ ECHClientHelloOuter+ { echCipherSuite = (HKDF_SHA256, AES_128_GCM)+ , echConfigId = cid+ , echEnc = EncodedPublicKey enc+ , echPayload = payload+ }+ return $ toExtensionRaw outer++#if !MIN_VERSION_random(1,3,0)+uniformByteString :: RandomGen g => Int -> g -> (ByteString, g)+uniformByteString l g0 = (bs, g2)+ where+ (g1, g2) = split g0+ bs = unsafeCreate l $ go 0 g1+ go n g ptr+ | n == l = return ()+ | otherwise = do+ let (w, g') = genWord8 g+ poke ptr w+ go (n + 1) g' (plusPtr ptr 1)+#endif
Network/TLS/Handshake/Client/Common.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.Common ( throwMiscErrorOnException,@@ -9,6 +10,7 @@ sigAlgsToCertTypes, setALPN, contextSync,+ clientSessions, ) where import Control.Exception (SomeException)@@ -332,19 +334,30 @@ ---------------------------------------------------------------- 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 () ---------------------------------------------------------------- contextSync :: Context -> ClientState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync sync _ -> sync ctx ctl++clientSessions :: ClientParams -> [(SessionID, SessionData)]+clientSessions ClientParams{..} = case clientWantSessionResume of+ Nothing -> clientWantSessionResumeList+ Just ent -> clientWantSessionResumeList ++ [ent]
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client.ServerHello (- recvServerHello,+ receiveServerHello, processServerHello13, ) where +import Data.ByteArray (convert)+import qualified Data.ByteString as B+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -12,13 +16,14 @@ import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Random import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -27,13 +32,27 @@ ---------------------------------------------------------------- -recvServerHello- :: ClientParams -> Context -> IO [Handshake]-recvServerHello cparams ctx = do- (sh, hss) <- recvSH+receiveServerHello+ :: ClientParams+ -> Context+ -> Maybe (ClientRandom, Session, Version)+ -> IO (Version, [HandshakeR], Bool)+receiveServerHello cparams ctx mparams = do+ chSentTime <- getCurrentTimeFromBase+ (shb@(sh, _), hbs) <- recvSH processServerHello cparams ctx sh- processHandshake12 ctx sh- return hss+ updateTranscriptHash12 ctx shb+ setRTT ctx chSentTime+ ver <- usingState_ ctx getVersion+ unless (maybe True (\(_, _, v) -> v == ver) mparams) $+ throwCore $+ Error_Protocol "version changed after hello retry" IllegalParameter+ -- recvServerHello sets TLS13HRR according to the server random.+ -- For 1st server hello, getTLS13HR returns True if it is HRR and+ -- False otherwise. For 2nd server hello, getTLS13HR returns+ -- False since it is NOT HRR.+ hrr <- usingState_ ctx getTLS13HRR+ return (ver, hbs, hrr) where recvSH = do epkt <- recvPacket12 ctx@@ -41,7 +60,7 @@ Left e -> throwCore e Right pkt -> case pkt of Alert a -> throwAlert a- Handshake (h : hs) -> return (h, hs)+ Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs) _ -> unexpected (show pkt) (Just "handshake") throwAlert a = throwCore $@@ -53,71 +72,80 @@ processServerHello13 :: ClientParams -> Context -> Handshake13 -> IO ()-processServerHello13 cparams ctx (ServerHello13 serverRan serverSession cipher exts) = do- let sh = ServerHello TLS12 serverRan serverSession cipher 0 exts- processServerHello cparams ctx sh+processServerHello13 cparams ctx (ServerHello13 sh13) = do+ let sh12 = ServerHello sh13+ processServerHello cparams ctx sh12 processServerHello13 _ _ h = unexpected (show h) (Just "server hello") -- | processServerHello processes the ServerHello message on the client. ----- 1) check the version chosen by the server is one allowed by parameters.--- 2) check that our compression and cipher algorithms are part of the list we sent+-- 1) check the version chosen by the server is one allowed by+-- parameters.+-- 2) check that our compression and cipher algorithms are part of the+-- list we sent -- 3) check extensions received are part of the one we sent--- 4) process the session parameter to see if the server want to start a new session or can resume+-- 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 sh@SH{..}) = do -- A server which receives a legacy_version value not equal to -- 0x0303 MUST abort the handshake with an "illegal_parameter" -- alert.- when (rver /= TLS12) $+ when (shVersion /= TLS12) $ throwCore $- Error_Protocol (show rver ++ " is not supported") IllegalParameter+ Error_Protocol (show shVersion ++ " is not supported") IllegalParameter -- 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+ chExts <- tls13stSentExtensions <$> getTLS13State ctx+ let clientCiphers = supportedCiphers $ ctxSupported ctx+ usedCipher <- case findCipher (fromCipherId shCipher) clientCiphers of Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter Just alg -> return alg compressAlg <- case find- ((==) compression . compressionID)+ ((==) shComp . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter Just alg -> return alg- ensureNullCompression compression+ ensureNullCompression shComp - -- intersect sent extensions in client and the received extensions from server.- -- if server returns extensions that we didn't request, fail.+ -- intersect sent extensions in client and the received extensions+ -- from server. if server returns extensions that we didn't+ -- request, fail. let checkExt (ExtensionRaw i _) | i == EID_Cookie = False -- for HRR- | otherwise = i `notElem` sentExts- when (any checkExt exts) $+ | otherwise = i `notElem` chExts+ when (any checkExt shExtensions) $ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension - let isHRR = isHelloRetryRequest serverRan+ let isHRR = isHelloRetryRequest shRandom usingState_ ctx $ do setTLS13HRR isHRR- setTLS13Cookie- ( guard isHRR- >> extensionLookup EID_Cookie exts- >>= extensionDecode MsgTServerHello- )- setVersion rver -- must be before processing supportedVersions ext- mapM_ processServerExtension exts+ when isHRR $+ setTLS13Cookie $+ lookupAndDecode+ EID_Cookie+ MsgTServerHello+ shExtensions+ Nothing+ (\cookie@(Cookie _) -> Just cookie)+ setVersion shVersion -- must be before processing supportedVersions ext+ mapM_ processServerExtension shExtensions - setALPN ctx MsgTServerHello exts+ setALPN ctx MsgTServerHello shExtensions ver <- usingState_ ctx getVersion - when (ver == TLS12) $ do- usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg+ when (ver == TLS12) $+ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg let supportedVers = supportedVersions $ clientSupported cparams when (ver == TLS13) $ do- when (clientSession /= serverSession) $+ -- TLS 1.3 server MUST echo the session id+ when (clientSession /= shSession) $ throwCore $ Error_Protocol "session is not matched in compatibility mode"@@ -128,28 +156,48 @@ ("server version " ++ show ver ++ " is not supported") ProtocolVersion - -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3- -- in the supported_versions extension, *AND ALSO* set the TLS 1.2- -- downgrade signal in the server random. If we support TLS 1.3 and- -- actually negotiate TLS 1.3, we must ignore the server random downgrade- -- signal. Therefore, 'isDowngraded' needs to take into account the- -- negotiated version and the server random, as well as the list of- -- client-side enabled protocol versions.+ -- Some servers set TLS 1.2 as the legacy server hello version,+ -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set+ -- the TLS 1.2 downgrade signal in the server random. If we+ -- support TLS 1.3 and actually negotiate TLS 1.3, we must ignore+ -- the server random downgrade signal. Therefore, 'isDowngraded'+ -- needs to take into account the negotiated version and the+ -- server random, as well as the list of client-side enabled+ -- protocol versions. --- when (isDowngraded ver supportedVers serverRan) $+ when (isDowngraded ver supportedVers shRandom) $ throwCore $ Error_Protocol "version downgrade detected" IllegalParameter - let resumingSession =- case clientWantSessionResume cparams of- Just (_, sessionData) ->- if serverSession == clientSession then Just sessionData else Nothing- Nothing -> Nothing- usingState_ ctx $ setSession serverSession (isJust resumingSession)- if ver == TLS13- then updateContext13 ctx cipherAlg- else updateContext12 ctx exts resumingSession+ then do+ -- Session is dummy in TLS 1.3.+ usingState_ ctx $ setSession shSession+ processRecordSizeLimit ctx shExtensions True+ enableMyRecordLimit ctx+ enablePeerRecordLimit ctx+ let usedHash = cipherHash usedCipher+ transitTranscriptHashI ctx "transitI" usedHash isHRR+ accepted <- checkECHacceptance ctx isHRR usedHash sh+ when accepted $ do+ (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello+ usingHState ctx $ setClientRandom chRandom -- inner random+ when (accepted && not isHRR) $ do+ copyTranscriptHash ctx "copy"+ usingHState ctx $ setECHAccepted True+ updateContext13 ctx usedCipher isHRR+ updateTranscriptHashI ctx "ServerHelloI" $ encodeHandshake $ ServerHello sh+ else do+ let resumingSession = case clientSessions cparams of+ (_, sessionData) : _ ->+ if shSession == clientSession then Just sessionData else Nothing+ _ -> Nothing++ usingState_ ctx $ do+ setSession shSession+ setTLS12SessionResuming $ isJust resumingSession+ processRecordSizeLimit ctx shExtensions False+ updateContext12 ctx shExtensions resumingSession processServerHello _ _ p = unexpected (show p) (Just "server hello") ----------------------------------------------------------------@@ -157,8 +205,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 $@@ -177,8 +225,8 @@ ---------------------------------------------------------------- -updateContext13 :: Context -> Cipher -> IO ()-updateContext13 ctx cipherAlg = do+updateContext13 :: Context -> Cipher -> Bool -> IO ()+updateContext13 ctx usedCipher isHRR = do established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $@@ -186,11 +234,11 @@ Error_Protocol "renegotiation to TLS 1.3 or later is not allowed" ProtocolVersion- failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher isHRR updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()-updateContext12 ctx exts resumingSession = do- ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello exts+updateContext12 ctx shExtensions resumingSession = do+ ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello shExtensions case resumingSession of Nothing -> return () Just sessionData -> do@@ -198,6 +246,61 @@ when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol err HandshakeFailure- let mainSecret = sessionSecret sessionData+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret)++----------------------------------------------------------------++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO ()+processRecordSizeLimit ctx shExtensions tls13 = do+ let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx+ case mmylim of+ Nothing -> return ()+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ shExtensions+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ ack <- checkPeerRecordLimit ctx+ -- When a client sends RecordSizeLimit, it does not know+ -- which TLS version the server selects. RecordLimit is+ -- the length of plaintext. But RecordSizeLimit also+ -- includes CT: and padding for TLS 1.3. To convert+ -- RecordSizeLimit to RecordLimit, we should reduce the+ -- value by 1, which is the length of CT:.+ when (ack && tls13) $ setMyRecordLimit ctx $ Just (mylim - 1)++----------------------------------------------------------------++checkECHacceptance :: Context -> Bool -> Hash -> ServerHello -> IO Bool+checkECHacceptance ctx False usedHash sh@SH{..} = do+ let (prefix, confirm) = B.splitAt 24 $ unServerRandom shRandom+ sr' = ServerRandom (prefix <> "\x00\x00\x00\x00\x00\x00\x00\x00")+ verified <-+ computeConfirm ctx usedHash sh{shRandom = sr'} "ech accept confirmation"+ return (confirm == verified)+checkECHacceptance ctx True usedHash sh@SH{..} = do+ case replace shExtensions of+ Nothing -> return False+ Just (confirm, shExts') -> do+ verified <-+ computeConfirm+ ctx+ usedHash+ sh{shExtensions = shExts'}+ "hrr ech accept confirmation"+ return (confirm == verified)+ where+ replace [] = Nothing+ replace (ExtensionRaw EID_EncryptedClientHello confirm : es) =+ Just+ ( confirm+ , ExtensionRaw EID_EncryptedClientHello "\x00\x00\x00\x00\x00\x00\x00\x00" : es+ )+ replace (e : es) = case replace es of+ Nothing -> Nothing+ Just (confirm, es') -> Just (confirm, e : es')
Network/TLS/Handshake/Client/TLS12.hs view
@@ -8,6 +8,7 @@ ) where import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -32,17 +33,18 @@ ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()-recvServerFirstFlight12 cparams ctx hs = do- resuming <- usingState_ ctx isSessionResuming+recvServerFirstFlight12+ :: ClientParams -> Context -> [HandshakeR] -> IO ()+recvServerFirstFlight12 cparams ctx hbs = do+ resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx)- runRecvStateHS ctx st hs+ runRecvStateHS ctx st hbs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)-expectCertificate cparams ctx (Certificate certs) = do+expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do usingState_ ctx $ setServerCertificateChain certs doCertificate cparams ctx certs processCertificate ctx ClientRole certs@@ -72,32 +74,35 @@ sendClientSecondFlight12 :: ClientParams -> Context -> IO () sendClientSecondFlight12 cparams ctx = do- sessionResuming <- usingState_ ctx isSessionResuming+ sessionResuming <- usingState_ ctx getTLS12SessionResuming if sessionResuming then sendCCSandFinished ctx ClientRole else do sendClientCCC cparams ctx sendCCSandFinished ctx ClientRole -recvServerSecondFlight12 :: Context -> IO ()-recvServerSecondFlight12 ctx = do- sessionResuming <- usingState_ ctx isSessionResuming+recvServerSecondFlight12 :: ClientParams -> Context -> IO ()+recvServerSecondFlight12 cparams ctx = do+ sessionResuming <- usingState_ ctx getTLS12SessionResuming unless sessionResuming $ recvNSTandCCSandFinished ctx mticket <- usingState_ ctx getTLS12SessionTicket- identity <- case mticket of- Just ticket -> return ticket- Nothing -> do- session <- usingState_ ctx getSession- case session of- Session (Just sessionId) -> return $ B.copy sessionId- _ -> return "" -- never reach- sessionData <- getSessionData ctx- void $- sessionEstablish- (sharedSessionManager $ ctxShared ctx)- identity- (fromJust sessionData)- handshakeDone12 ctx+ session <- usingState_ ctx getSession+ let midentity = ticketOrSessionID12 mticket session+ case midentity of+ Nothing -> return ()+ Just identity -> do+ sessionData <- getSessionData ctx+ void $+ sessionEstablish+ (sharedSessionManager $ ctxShared ctx)+ identity+ (fromJust sessionData)+ finishHandshake12 ctx+ liftIO $ do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> return ()+ Just info -> onServerFinished (clientHooks cparams) info recvNSTandCCSandFinished :: Context -> IO () recvNSTandCCSandFinished ctx = do@@ -112,6 +117,7 @@ expectNewSessionTicket p = unexpected (show p) (Just "Handshake Finished") expectChangeCipher ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipher p = unexpected (show p) (Just "change cipher") @@ -147,7 +153,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True- sendPacket12 ctx $ Handshake [Certificate cc]+ sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] [] ---------------------------------------------------------------- @@ -163,19 +169,19 @@ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure- sendPacket12 ctx $ Handshake [ClientKeyXchg ckx]+ sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] [] mainSecret <- usingHState ctx setMainSec logKey ctx (MainSecret mainSecret) -------------------------------- getCKX_RSA- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_RSA ctx = do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 - let preMain = encodePreMainSecret clientVersion prerand+ let preMain = convert $ encodePreMainSecret clientVersion prerand setMainSec = setMainSecretFromPre xver ClientRole preMain encryptedPreMain <- do -- SSL3 implementation generally forget this length field since it's redundant,@@ -190,7 +196,7 @@ getCKX_DHE :: ClientParams -> Context- -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_DHE cparams ctx = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams@@ -237,12 +243,12 @@ -------------------------------- getCKX_ECDHE- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_ECDHE ctx = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setSupportedGroup grp- ecdhePair <- generateECDHEShared ctx srvpub+ ecdhePair <- encapsulateGroup ctx srvpub case ecdhePair of Nothing -> throwCore $@@ -250,7 +256,7 @@ Just (clipub, preMain) -> do xver <- usingState_ ctx getVersion let setMainSec = setMainSecretFromPre xver ClientRole preMain- return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec)+ return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec) ---------------------------------------------------------------- @@ -279,4 +285,4 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs- sendPacket12 ctx $ Handshake [CertVerify sigDig]+ sendPacket12 ctx $ Handshake [CertVerify sigDig] []
Network/TLS/Handshake/Client/TLS13.hs view
@@ -9,12 +9,13 @@ import Control.Exception (bracket) import Control.Monad.State.Strict-import qualified Data.ByteString as B+import qualified Data.ByteArray as BA import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Error import Network.TLS.Extension import Network.TLS.Handshake.Client.Common import Network.TLS.Handshake.Client.ServerHello@@ -22,10 +23,10 @@ import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Control import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters@@ -38,25 +39,25 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -recvServerSecondFlight13 :: ClientParams -> Context -> Maybe Group -> IO ()+recvServerSecondFlight13 :: ClientParams -> Context -> [Group] -> IO () recvServerSecondFlight13 cparams ctx groupSent = do resuming <- prepareSecondFlight13 ctx groupSent runRecvHandshake13 $ do recvHandshake13 ctx $ expectEncryptedExtensions ctx unless resuming $ recvHandshake13 ctx $ expectCertRequest cparams ctx- recvHandshake13hash ctx $ expectFinished ctx+ recvHandshake13hash ctx "Finished" $ expectFinished cparams ctx ---------------------------------------------------------------- prepareSecondFlight13- :: Context -> Maybe Group -> IO Bool+ :: Context -> [Group] -> IO Bool prepareSecondFlight13 ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher prepareSecondFlight13' ctx groupSent choice prepareSecondFlight13' :: Context- -> Maybe Group+ -> [Group] -> CipherChoice -> IO Bool prepareSecondFlight13' ctx groupSent choice = do@@ -99,10 +100,10 @@ "key exchange not implemented, expected key_share extension" HandshakeFailure let grp = keyShareEntryGroup serverKeyShare- unless (checkKeyShareKeyLength serverKeyShare) $+ unless (checkServerKeyShareKeyLength serverKeyShare) $ throwCore $ Error_Protocol "broken key_share" IllegalParameter- unless (groupSent == Just grp) $+ unless (grp `elem` groupSent) $ throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter usingHState ctx $ setSupportedGroup grp@@ -118,7 +119,7 @@ Nothing -> return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do- unless (B.length sec == hashSize) $+ unless (BA.length sec == hashSize) $ throwCore $ Error_Protocol "selected cipher is incompatible with selected PSK"@@ -146,12 +147,13 @@ Nothing -> do usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected-expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions")+expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx $ expectCertAndVerify cparams ctx@@ -177,15 +179,21 @@ Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure -- Unused: -- caAlgs <- extalgs caextID uncertsig+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ exts+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas) usingHState ctx $ do setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)+ setTLS13CertComp zlib where -- setCertReqSigAlgsCert caAlgs - 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@@ -204,41 +212,55 @@ ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()-expectCertAndVerify cparams ctx (Certificate13 _ cc _) = do+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc+expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate")++processCertAndVerify+ :: MonadIO m+ => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m ()+processCertAndVerify cparams ctx cc = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey- recvHandshake13hash ctx $ expectCertVerify ctx pubkey-expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate")+ recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey ---------------------------------------------------------------- expectCertVerify- :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m ()-expectCertVerify ctx pubkey hChSc (CertVerify13 sigAlg sig) = do+ :: MonadIO m+ => Context -> PubKey -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify ctx pubkey (TranscriptHash 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")+expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify") ---------------------------------------------------------------- expectFinished :: MonadIO m- => Context- -> ByteString+ => ClientParams+ -> Context+ -> TranscriptHash -> Handshake13 -> m ()-expectFinished ctx hashValue (Finished13 verifyData) = do+expectFinished cparams ctx hashValue (Finished13 verifyData) = do st <- liftIO $ getTLS13State ctx let usedHash = cHash $ tls13stChoice st ServerTrafficSecret baseKey = triServer $ fromJust $ tls13stHsKey st checkFinished ctx usedHash baseKey hashValue verifyData+ liftIO $ do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> return ()+ Just info -> onServerFinished (clientHooks cparams) info liftIO $ modifyTLS13State ctx $ \s -> s{tls13stRecvSF = True}-expectFinished _ _ p = unexpected (show p) (Just "server finished")+expectFinished _ _ _ p = unexpected (show p) (Just "server finished") ---------------------------------------------------------------- ----------------------------------------------------------------@@ -252,6 +274,10 @@ eexts = tls13stClientExtensions st sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts modifyTLS13State ctx $ \s -> s{tls13stSentCF = True}+ echAccepted <- usingHState ctx getECHAccepted+ when (clientUseECH cparams && not echAccepted) $+ throwCore $+ Error_Protocol "ECH is not accepted" EchRequired sendClientSecondFlight13' :: ClientParams@@ -262,12 +288,12 @@ -> [ExtensionRaw] -> IO () sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" unless (ctxQUICMode ctx) $ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $- sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+ sendPacket13 ctx (Handshake13 [EndOfEarlyData13] []) let clientHandshakeSecret = triClient hkey setTxRecordState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret@@ -277,7 +303,7 @@ let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) contextSync ctx $ SendClientFinished eexts appSecInfo modifyTLS13State ctx $ \st -> st{tls13stHsKey = Nothing}- handshakeDone13 ctx+ finishHandshake13 ctx rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ do builder <- tls13stPendingSentData <$> getTLS13State ctx@@ -316,39 +342,45 @@ runPacketFlight ctx $ do case mcc of Nothing -> return ()- Just cc -> usingHState ctx getCertReqToken >>= loadClientData13 cc+ Just cc -> do+ reqtoken <- usingHState ctx getCertReqToken+ certComp <- usingHState ctx getTLS13CertComp+ loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True} where- loadClientData13 chain (Just token) = do+ loadClientData13 chain (Just token) certComp = do let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx- loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]+ let certtag = if certComp then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag token (CertificateChain_ chain) certExts] [] case certs of [] -> return () _ -> do- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubKey <- getLocalPublicKey ctx sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc- loadPacket13 ctx $ Handshake13 [vfy]+ loadPacket13 ctx $ Handshake13 [vfy] [] --- loadClientData13 _ _ =+ loadClientData13 _ _ _ = throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =+postHandshakeAuthClientWith+ :: ClientParams -> Context -> Handshake13 -> IO ()+postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- processHandshake13 ctx h+ -- updateTranscriptHash13 ctx h b processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $@@ -356,7 +388,11 @@ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage- sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN)+ sendClientFlight13+ cparams+ ctx+ usedHash+ (ClientTrafficSecret applicationSecretN) postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol@@ -367,25 +403,22 @@ ---------------------------------------------------------------- asyncServerHello13- :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO ()+ :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx- [ PendingRecvAction True expectServerHello- , PendingRecvAction- True- (expectEncryptedExtensions ctx)- , PendingRecvActionHash- True- expectFinishedAndSet+ [ PendingRecvActionSelfUpdate True expectServerHello+ , PendingRecvAction True (expectEncryptedExtensions ctx)+ , PendingRecvActionHash True expectFinishedAndSet ] where- expectServerHello sh = do+ expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh+ updateTranscriptHash13 ctx shb -- update by myself void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do- expectFinished ctx h sf+ expectFinished cparams ctx h sf liftIO $ writeIORef (ctxPendingSendAction ctx) $ Just $
Network/TLS/Handshake/Common.hs view
@@ -6,8 +6,8 @@ handleException, unexpected, newSession,- handshakeDone12, ensureNullCompression,+ ticketOrSessionID12, -- * sending packets sendCCSandFinished,@@ -20,7 +20,6 @@ onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret,- extensionLookup, getSessionData, storePrivInfo, isSupportedGroup,@@ -29,11 +28,22 @@ errorToAlertMessage, expectFinished, processCertificate,+ --+ setPeerRecordSizeLimit,+ generateFinished,+ encodeUpdateTranscriptHash12,+ updateTranscriptHash12,+ --+ startHandshake,+ finishHandshake12,+ setServerHelloParameters12, ) where import Control.Concurrent.MVar import Control.Exception (IOException, fromException, handle, throwIO) import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Compression@@ -41,13 +51,15 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -61,6 +73,7 @@ handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do+ debugError (ctxDebug ctx) $ show exception -- If the error was an Uncontextualized TLSException, we replace the -- context with HandshakeFailed. If it's anything else, we convert -- it to a string and wrap it with Error_Misc and HandshakeFailed.@@ -74,7 +87,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@@ -109,26 +124,6 @@ | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing --- | when a new handshake is done, wrap up & clean up.-handshakeDone12 :: Context -> IO ()-handshakeDone12 ctx = do- -- forget most handshake data and reset bytes counters.- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstExtendedMainSecret = hstExtendedMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- }- updateMeasure ctx resetBytesCounters- -- mark the secure connection up and running.- setEstablished ctx Established- return ()- sendCCSandFinished :: Context -> Role@@ -136,9 +131,10 @@ sendCCSandFinished ctx role = do sendPacket12 ctx ChangeCipherSpec contextFlush ctx- verifyData <-- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role- sendPacket12 ctx (Handshake [Finished verifyData])+ enablePeerRecordLimit ctx+ ver <- usingState_ ctx getVersion+ verifyData <- VerifyData <$> generateFinished ctx ver role+ sendPacket12 ctx (Handshake [Finished verifyData] []) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -147,11 +143,11 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake]+recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do pkts <- recvPacket12 ctx case pkts of- Right (Handshake l) -> return l+ Right (Handshake hss bss) -> return $ zip hss bss Right x@(AppData _) -> do -- If a TLS13 server decides to reject RTT0 data, the server should -- skip records for RTT0 data up to the maximum limit.@@ -167,16 +163,18 @@ -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake- :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)+ :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState-onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms)-onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do- let finished = isFinished x- unless finished $ processHandshake12 ctx x- nstate <- f x- when finished $ processHandshake12 ctx x- onRecvStateHandshake ctx nstate xs-onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing+onRecvStateHandshake _ (RecvStatePacket f) hbs = do+ let (hss, bss) = unzip hbs+ f (Handshake hss bss)+onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do+ let finished = isFinished h+ unless finished $ void $ updateTranscriptHash12 ctx hb+ nstate <- f h+ when finished $ void $ updateTranscriptHash12 ctx hb+ onRecvStateHandshake ctx nstate hbs+onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True@@ -190,8 +188,9 @@ >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()-runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx+runRecvStateHS+ :: Context -> RecvState IO -> [HandshakeR] -> IO ()+runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do@@ -207,14 +206,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@@ -236,7 +244,7 @@ , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni- , sessionSecret = ms+ , sessionSecret = convert ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn@@ -244,11 +252,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@@ -298,8 +301,8 @@ processFinished :: Context -> VerifyData -> IO () processFinished ctx verifyData = do (cc, ver) <- usingState_ ctx $ (,) <$> getRole <*> getVersion- expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc- when (expected /= verifyData) $ decryptError "cannot verify finished"+ expected <- VerifyData <$> generateFinished ctx ver (invertRole cc)+ when (expected /= verifyData) $ decryptError "finished verification failed" usingState_ ctx $ setVerifyDataForRecv verifyData processCertificate :: Context -> Role -> CertificateChain -> IO ()@@ -310,3 +313,130 @@ usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c++-- TLS 1.2 distinguishes session ID and session ticket. session+-- ticket. Session ticket is prioritized over session ID.+ticketOrSessionID12+ :: Maybe Ticket -> Session -> Maybe SessionIDorTicket+ticketOrSessionID12 (Just ticket) _+ | ticket /= "" = Just $ B.copy ticket+ticketOrSessionID12 _ (Session (Just sessionId)) = Just $ B.copy sessionId+ticketOrSessionID12 _ _ = Nothing++setPeerRecordSizeLimit :: Context -> Bool -> RecordSizeLimit -> IO ()+setPeerRecordSizeLimit ctx tls13 (RecordSizeLimit n0) = do+ when (n0 < 64) $+ throwCore $+ Error_Protocol ("too small recode size limit: " ++ show n0) IllegalParameter++ -- RFC 8449 Section 4:+ -- Even if a larger record size limit is provided by a peer, an+ -- endpoint MUST NOT send records larger than the protocol-defined+ -- limit, unless explicitly allowed by a future TLS version or+ -- extension.+ let n1 = fromIntegral n0+ n2+ | n1 > protolim = protolim+ | otherwise = n1+ -- Even if peer's value is larger than the protocol-defined+ -- limitation, call "setPeerRecordLimit" to send+ -- "record_size_limit" as ACK. In this case, the protocol-defined+ -- limitation is used.+ let lim = if tls13 then n2 - 1 else n2+ setPeerRecordLimit ctx $ Just lim+ where+ protolim+ | tls13 = defaultRecordSizeLimit + 1+ | otherwise = defaultRecordSizeLimit++----------------------------------------------------------------++generateFinished :: Context -> Version -> Role -> IO ByteString+generateFinished ctx ver role = do+ thash <- transcriptHash ctx "generateFinished"+ (mainSecret, cipher) <- usingHState ctx $ gets $ \hst ->+ (fromJust $ hstMainSecret hst, fromJust $ hstPendingCipher hst)+ return $+ if role == ClientRole+ then+ generateClientFinished ver cipher mainSecret thash+ else+ generateServerFinished ver cipher mainSecret thash++generateFinished'+ :: PRF -> ByteString -> Secret -> TranscriptHash -> ByteString+generateFinished' prf label mainSecret (TranscriptHash thash) = convert $ prf mainSecret seed 12+ where+ seed = label <> thash++generateClientFinished+ :: Version+ -> Cipher+ -> Secret+ -> TranscriptHash+ -> ByteString+generateClientFinished ver ciph =+ generateFinished' (getPRF ver ciph) "client finished"++generateServerFinished+ :: Version+ -> Cipher+ -> Secret+ -> TranscriptHash+ -> ByteString+generateServerFinished ver ciph =+ generateFinished' (getPRF ver ciph) "server finished"++----------------------------------------------------------------++-- initialize a new Handshake context (initial handshake or renegotiations)+startHandshake :: Context -> Version -> ClientRandom -> IO ()+startHandshake ctx ver crand =+ void $ swapMVar (ctxHandshakeState ctx) $ Just hs+ where+ hs = newEmptyHandshake ver crand++setServerHelloParameters12+ :: Context+ -> Version+ -- ^ chosen version+ -> ServerRandom+ -> Cipher+ -> Compression+ -> IO ()+setServerHelloParameters12 ctx ver sran cipher compression = do+ usingHState ctx $+ modify' $ \hst ->+ hst+ { hstServerRandom = Just sran+ , hstPendingCipher = Just cipher+ , hstPendingCompression = compression+ }+ transitTranscriptHash ctx "transit" (getHash ver cipher) False++-- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384+-- instead of the default SHA256.+getHash :: Version -> Cipher -> Hash+getHash ver ciph+ | ver < TLS12 = SHA1_MD5+ | maybe True (< TLS12) (cipherMinVer ciph) = SHA256+ | otherwise = cipherHash ciph++-- | when a new handshake is done, wrap up & clean up.+finishHandshake12 :: Context -> IO ()+finishHandshake12 ctx = do+ -- forget most handshake data and reset bytes counters.+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstExtendedMainSecret = hstExtendedMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ }+ updateMeasure ctx resetBytesCounters+ -- mark the secure connection up and running.+ setEstablished ctx Established
Network/TLS/Handshake/Common13.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,7 +15,6 @@ makePSKBinder, replacePSKBinder, sendChangeCipherSpec13,- handshakeDone13, makeCertRequest, createTLS13TicketInfo, ageToObfuscatedAge,@@ -37,11 +37,18 @@ calculateApplicationSecret, calculateResumptionSecret, derivePSK,- checkKeyShareKeyLength,+ checkClientKeyShareKeyLength,+ checkServerKeyShareKeyLength, setRTT,+ computeConfirm,+ updateTranscriptHash13,+ setServerHelloParameters13,+ finishHandshake13, ) where -import qualified Data.ByteArray as BA+import Control.Concurrent.MVar+import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..))@@ -50,18 +57,20 @@ import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES +import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname) import Network.TLS.Handshake.Common (unexpected) import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process (processHandshake13) import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC+import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct@@ -69,67 +78,71 @@ import Network.TLS.Types import Network.TLS.Wire -import Control.Concurrent.MVar-import Control.Monad.State.Strict- ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do- verifyData <- makeVerifyData usedHash baseKey <$> transcriptHash ctx+ verifyData <-+ VerifyData . makeVerifyData usedHash baseKey+ <$> transcriptHash ctx "makeFinished" liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData pure $ Finished13 verifyData checkFinished- :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()-checkFinished ctx usedHash baseKey hashValue verifyData = do- let verifyData' = makeVerifyData usedHash baseKey hashValue+ :: MonadIO m+ => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m ()+checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do+ let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash 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+ unless (verifyData' == verifyData) $ decryptError "finished verification failed"+ liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString-makeVerifyData usedHash baseKey = hmac usedHash finishedKey+makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString+makeVerifyData usedHash baseKey (TranscriptHash th) =+ hmac usedHash finishedKey th where hashSize = hashDigestSize usedHash finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize ---------------------------------------------------------------- -makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)+makeClientKeyShare+ :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry)+makeClientKeyShare ctx grp = do+ (cpri, cpub) <- generateGroup ctx grp+ let wcpub = IES.groupEncodePublicA cpub+ clientKeyShare = KeyShareEntry grp wcpub+ return ((grp, cpri), clientKeyShare)++makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right cpub -> do- ecdhePair <- generateECDHEShared ctx cpub+ ecdhePair <- encapsulateGroup ctx cpub case ecdhePair of Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter Just (spub, share) ->- let wspub = IES.encodeGroupPublic spub+ let wspub = IES.groupEncodePublicB spub serverKeyShare = KeyShareEntry grp wspub- in return (BA.convert share, serverKeyShare)+ in return (share, serverKeyShare) where- ecpub = IES.decodeGroupPublic grp wcpub+ ecpub = IES.groupDecodePublicA grp wcpub msgInvalidPublic = "invalid client " ++ show grp ++ " public key" -makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)-makeClientKeyShare ctx grp = do- (cpri, cpub) <- generateECDHE ctx grp- let wcpub = IES.encodeGroupPublic cpub- clientKeyShare = KeyShareEntry grp wcpub- return (cpri, clientKeyShare)--fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString-fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of+fromServerKeyShare+ :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret+fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter- Right spub -> case IES.groupGetShared spub cpri of- Just shared -> return $ BA.convert shared- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ Right spub -> case lookup grp grpCpris of+ Nothing -> throwCore err+ Just cpri -> case IES.groupDecapsulate spub cpri of+ Just shared -> return shared+ Nothing -> throwCore err where- espub = IES.decodeGroupPublic grp wspub+ err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ espub = IES.groupDecodePublicB grp wspub ---------------------------------------------------------------- @@ -144,15 +157,15 @@ => Context -> PubKey -> HashAndSignatureAlgorithm- -> ByteString+ -> TranscriptHash -> m Handshake13-makeCertVerify ctx pub hs hashValue = do+makeCertVerify ctx pub hs (TranscriptHash hashValue) = do role <- liftIO $ usingState_ ctx getRole let ctxStr | 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@@ -197,32 +210,30 @@ ---------------------------------------------------------------- makePSKBinder- :: Context- -> BaseSecret EarlySecret+ :: BaseSecret EarlySecret -> Hash -> Int- -> 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- binderKey = deriveSecret usedHash sec "res binder" (hash usedHash "")- return $ makeVerifyData usedHash binderKey hChTruncated+ -> ByteString+ -- ^ Encoded client hello+ -> ByteString+makePSKBinder (BaseSecret sec) usedHash truncLen ech =+ makeVerifyData usedHash binderKey hChTruncated where+ hChTruncated = TranscriptHash $ hash usedHash $ trunc ech+ th = TranscriptHash $ hash usedHash ""+ binderKey = deriveSecret usedHash sec "res binder" th trunc x = B.take takeLen x where totalLen = B.length x takeLen = totalLen - truncLen -replacePSKBinder :: ByteString -> ByteString -> ByteString-replacePSKBinder pskz binder = identities `B.append` binders+replacePSKBinder :: ByteString -> [ByteString] -> ByteString+replacePSKBinder pskz bds = tLidentities <> binders where- bindersSize = B.length binder + 3- identities = B.take (B.length pskz - bindersSize) pskz- binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder+ tLidentities = B.take (B.length pskz - B.length binders) pskz+ -- See instance Extension PreSharedKey+ binders = runPut $ putOpaque16 $ runPut (mapM_ putBinder bds)+ putBinder = putOpaque8 ---------------------------------------------------------------- @@ -236,50 +247,27 @@ ---------------------------------------------------------------- --- | TLS13 handshake wrap up & clean up. Contrary to @handshakeDone@, this--- does not handle session, which is managed separately for TLS 1.3. This does--- not reset byte counters because renegotiation is not allowed. And a few more--- state attributes are preserved, necessary for TLS13 handshake modes, session--- tickets and post-handshake authentication.-handshakeDone13 :: Context -> IO ()-handshakeDone13 ctx = do- -- forget most handshake data- modifyMVar_ (ctxHandshakeState ctx) $ \case- Nothing -> return Nothing- Just hshake ->- return $- Just- (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))- { hstServerRandom = hstServerRandom hshake- , hstMainSecret = hstMainSecret hshake- , hstSupportedGroup = hstSupportedGroup hshake- , hstHandshakeDigest = hstHandshakeDigest hshake- , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake- , hstTLS13RTT0Status = hstTLS13RTT0Status hshake- , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake- }- -- forget handshake data stored in TLS state- usingState_ ctx $ do- setTLS13KeyShare Nothing- setTLS13PreSharedKey Nothing- -- mark the secure connection up and running.- setEstablished ctx Established+makeCertRequest+ :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13+makeCertRequest sparams ctx certReqCtx zlib =+ let sigAlgs = SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx+ signatureAlgExt = Just $ toExtensionRaw sigAlgs -----------------------------------------------------------------+ compCertExt+ | zlib = Just $ toExtensionRaw $ CompressCertificate [CCA_Zlib]+ | otherwise = Nothing -makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13-makeCertRequest sparams ctx certReqCtx =- let sigAlgs =- extensionEncode $- SignatureAlgorithms $- supportedHashSignatures $- ctxSupported ctx caDns = map extractCAname $ serverCACertificates sparams- caDnsEncoded = extensionEncode $ CertificateAuthorities caDns- caExtension- | null caDns = []- | otherwise = [ExtensionRaw EID_CertificateAuthorities caDnsEncoded]- crexts = ExtensionRaw EID_SignatureAlgorithms sigAlgs : caExtension+ caExt+ | null caDns = Nothing+ | otherwise = Just $ toExtensionRaw $ CertificateAuthorities caDns++ crexts =+ catMaybes+ [ {- 0x0d -} signatureAlgExt+ , {- 0x1b -} compCertExt+ , {- 0x2f -} caExt+ ] in CertRequest13 certReqCtx crexts ----------------------------------------------------------------@@ -389,7 +377,8 @@ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+newtype RecvHandshake13M m a+ = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13@@ -397,31 +386,41 @@ => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13 ctx f = getHandshake13 ctx >>= f+recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h recvHandshake13hash :: MonadIO m => Context- -> (ByteString -> Handshake13 -> RecvHandshake13M m a)+ -> String+ -> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13hash ctx f = do- d <- transcriptHash ctx- getHandshake13 ctx >>= f d+recvHandshake13hash ctx label f = do+ d <- transcriptHash ctx label+ getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13+getHandshake13+ :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of- (h : hs) -> found h hs- [] -> recvLoop+ hb : hbs -> found hb hbs+ _ -> recvLoop where- found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h+ found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of- Right (Handshake13 []) -> error "invalid recvPacket13 result"- Right (Handshake13 (h : hs)) -> found h hs- Right ChangeCipherSpec13 -> recvLoop+ Right (Handshake13 [] _) -> error "invalid recvPacket13 result"+ Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs+ Right ChangeCipherSpec13 -> do+ alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv+ if alreadyReceived+ then+ liftIO $ throwCore $ Error_Protocol "multiple CSS in TLS 1.3" UnexpectedMessage+ else do+ liftIO $ usingHState ctx $ setCCS13Recv True+ recvLoop+ Right (Alert13 _) -> throwCore Error_TCP_Terminate Right x -> unexpected (show x) (Just "handshake 13") Left err -> throwCore err @@ -442,6 +441,9 @@ in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13++{- isHashSignatureValid13 (HashIntrinsic, s) = s `elem` [ SignatureRSApssRSAeSHA256@@ -456,6 +458,7 @@ isHashSignatureValid13 (h, SignatureECDSA) = h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False+-} ---------------------------------------------------------------- @@ -463,18 +466,13 @@ :: Context -> CipherChoice -> Either ByteString (BaseSecret EarlySecret)- -> Bool -> IO (SecretPair EarlySecret)-calculateEarlySecret ctx choice maux initialized = do- hCh <-- if initialized- then transcriptHash ctx- else do- hmsgs <- usingHState ctx getHandshakeMessages- return $ hash usedHash $ B.concat hmsgs+calculateEarlySecret ctx choice maux = do+ (_ch, b) <- fromJust <$> usingHState ctx getClientHello+ let hCh = TranscriptHash $ hashChunks usedHash b let earlySecret = case maux of Right (BaseSecret sec) -> sec- Left psk -> hkdfExtract usedHash zero psk+ Left psk -> hkdfExtract usedHash zero (convert psk) clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets@@ -489,20 +487,21 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice- zeroOrPSK = fromMaybe zero mpsk+ zeroOrPSK = fromMaybe zero (convert <$> mpsk) calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret- -> ByteString+ -> Secret -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do- hChSh <- transcriptHash ctx- let handshakeSecret =+ hChSh <- transcriptHash ctx "CH..SH"+ let th = TranscriptHash $ hash usedHash ""+ handshakeSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) ecdhe let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh@@ -520,18 +519,19 @@ :: Context -> CipherChoice -> BaseSecret HandshakeSecret- -> ByteString+ -> TranscriptHash -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do- let applicationSecret =+ let th = TranscriptHash $ hash usedHash ""+ applicationSecret = hkdfExtract usedHash- (deriveSecret usedHash sec "derived" (hash usedHash ""))+ (deriveSecret usedHash sec "derived" th) zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf- usingState_ ctx $ setExporterSecret exporterSecret+ usingState_ ctx $ setTLS13ExporterSecret exporterSecret let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret@@ -551,15 +551,15 @@ -> BaseSecret ApplicationSecret -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do- hChCf <- transcriptHash ctx+ hChCf <- transcriptHash ctx "CH..CF" let resumptionSecret = deriveSecret usedHash sec "res master" hChCf return $ BaseSecret resumptionSecret where usedHash = cHash choice derivePSK- :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString-derivePSK choice (BaseSecret sec) nonce =+ :: CipherChoice -> BaseSecret ResumptionSecret -> TicketNonce -> ByteString+derivePSK choice (BaseSecret sec) (TicketNonce nonce) = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where usedHash = cHash choice@@ -567,28 +567,127 @@ ---------------------------------------------------------------- -checkKeyShareKeyLength :: KeyShareEntry -> Bool-checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key+checkClientKeyShareKeyLength :: KeyShareEntry -> Bool+checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key where grp = keyShareEntryGroup ks key = keyShareEntryKeyExchange ks -keyShareKeyLength :: Group -> Int-keyShareKeyLength P256 = 65 -- 32 * 2 + 1-keyShareKeyLength P384 = 97 -- 48 * 2 + 1-keyShareKeyLength P521 = 133 -- 66 * 2 + 1-keyShareKeyLength X25519 = 32-keyShareKeyLength X448 = 56-keyShareKeyLength FFDHE2048 = 256-keyShareKeyLength FFDHE3072 = 384-keyShareKeyLength FFDHE4096 = 512-keyShareKeyLength FFDHE6144 = 768-keyShareKeyLength FFDHE8192 = 1024-keyShareKeyLength _ = error "keyShareKeyLength"+{- FOURMOLU_DISABLE -}+clientKeyShareKeyLength :: Group -> Int+clientKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+clientKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+clientKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+clientKeyShareKeyLength X25519 = 32+clientKeyShareKeyLength X448 = 56+clientKeyShareKeyLength FFDHE2048 = 256+clientKeyShareKeyLength FFDHE3072 = 384+clientKeyShareKeyLength FFDHE4096 = 512+clientKeyShareKeyLength FFDHE6144 = 768+clientKeyShareKeyLength FFDHE8192 = 1024+clientKeyShareKeyLength MLKEM512 = 800+clientKeyShareKeyLength MLKEM768 = 1184+clientKeyShareKeyLength MLKEM1024 = 1568+clientKeyShareKeyLength X25519MLKEM768 = 1216+clientKeyShareKeyLength P256MLKEM768 = 1249+clientKeyShareKeyLength P384MLKEM1024 = 1665+clientKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -} +checkServerKeyShareKeyLength :: KeyShareEntry -> Bool+checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key+ where+ grp = keyShareEntryGroup ks+ key = keyShareEntryKeyExchange ks++{- FOURMOLU_DISABLE -}+serverKeyShareKeyLength :: Group -> Int+serverKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+serverKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+serverKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+serverKeyShareKeyLength X25519 = 32+serverKeyShareKeyLength X448 = 56+serverKeyShareKeyLength FFDHE2048 = 256+serverKeyShareKeyLength FFDHE3072 = 384+serverKeyShareKeyLength FFDHE4096 = 512+serverKeyShareKeyLength FFDHE6144 = 768+serverKeyShareKeyLength FFDHE8192 = 1024+serverKeyShareKeyLength MLKEM512 = 768+serverKeyShareKeyLength MLKEM768 = 1088+serverKeyShareKeyLength MLKEM1024 = 1568+serverKeyShareKeyLength X25519MLKEM768 = 1120+serverKeyShareKeyLength P256MLKEM768 = 1153+serverKeyShareKeyLength P384MLKEM1024 = 1665+serverKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -}+ setRTT :: Context -> Millisecond -> IO () setRTT ctx chSentTime = do shRecvTime <- getCurrentTimeFromBase let rtt' = shRecvTime - chSentTime rtt = if rtt' == 0 then 10 else rtt' modifyTLS13State ctx $ \st -> st{tls13stRTT = rtt}++computeConfirm+ :: (MonadFail m, MonadIO m)+ => Context -> Hash -> ServerHello -> ByteString -> m ByteString+computeConfirm ctx usedHash sh label = do+ (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello)+ TranscriptHash echConf <-+ transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh+ let prk = hkdfExtract usedHash "" $ unClientRandom chRandom+ return $ hkdfExpandLabel usedHash (convert prk) label echConf 8++----------------------------------------------------------------++setServerHelloParameters13+ :: Context -> Cipher -> Bool -> IO (Either TLSError ())+setServerHelloParameters13 ctx cipher isHRR = do+ transitTranscriptHash ctx "transit" (cipherHash cipher) isHRR+ usingHState ctx $ do+ hst <- get+ case hstPendingCipher hst of+ Nothing -> do+ put+ hst+ { hstPendingCipher = Just cipher+ , hstPendingCompression = nullCompression+ }+ return $ Right ()+ Just oldcipher+ | cipher == oldcipher -> return $ Right ()+ | otherwise ->+ return $+ Left $+ Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter++-- | TLS13 handshake wrap up & clean up. Contrary to+-- @finishHandshake12@, this does not handle session, which is managed+-- separately for TLS 1.3. This does not reset byte counters because+-- renegotiation is not allowed. And a few more state attributes are+-- preserved, necessary for TLS13 handshake modes, session tickets and+-- post-handshake authentication.+finishHandshake13 :: Context -> IO ()+finishHandshake13 ctx = do+ -- forget most handshake data+ modifyMVar_ (ctxHandshakeState ctx) $ \case+ Nothing -> return Nothing+ Just hshake ->+ return $+ Just+ (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))+ { hstServerRandom = hstServerRandom hshake+ , hstMainSecret = hstMainSecret hshake+ , hstSupportedGroup = hstSupportedGroup hshake+ , hstTransHashState = hstTransHashState hshake+ , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake+ , hstTLS13RTT0Status = hstTLS13RTT0Status hshake+ , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake+ , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake+ }+ -- forget handshake data stored in TLS state+ usingState_ ctx $ do+ setTLS13KeyShare Nothing+ setTLS13PreSharedKey Nothing+ -- mark the secure connection up and running.+ setEstablished ctx Established
Network/TLS/Handshake/Key.hs view
@@ -7,8 +7,8 @@ decryptRSA, verifyPublic, generateDHE,- generateECDHE,- generateECDHEShared,+ generateGroup,+ encapsulateGroup, generateFFDHE, generateFFDHEShared, versionCompatible,@@ -20,13 +20,14 @@ ) where import Control.Monad.State.Strict-+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Handshake.State import Network.TLS.Imports+import Network.TLS.Parameters import Network.TLS.State (withRNG) import Network.TLS.Struct import Network.TLS.Types@@ -35,7 +36,7 @@ {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. -}-encryptRSA :: Context -> ByteString -> IO ByteString+encryptRSA :: Context -> Secret -> IO ByteString encryptRSA ctx content = do publicKey <- usingHState ctx getRemotePublicKey usingState_ ctx $ do@@ -53,7 +54,7 @@ Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent -decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString)+decryptRSA :: Context -> ByteString -> IO (Either KxError Secret) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do@@ -69,12 +70,12 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic)-generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp+generateGroup :: Context -> Group -> IO (GroupPrivate, GroupPublicA)+generateGroup ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared- :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))-generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub+encapsulateGroup+ :: Context -> GroupPublicA -> IO (Maybe (GroupPublicB, GroupKey))+encapsulateGroup ctx pub = usingState_ ctx $ withRNG $ groupEncapsulate pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp@@ -144,7 +145,7 @@ ---------------------------------------------------------------- class LogLabel a where- labelAndKey :: a -> (String, ByteString)+ labelAndKey :: a -> (String, Secret) instance LogLabel MainSecret where labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key)@@ -172,8 +173,10 @@ case mhst of Nothing -> return () Just hst -> do- let cr = unClientRandom $ hstClientRandom hst+ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst)+ cr = unClientRandom crm (label, key) = labelAndKey logkey- ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key+ debugKeyLogger (ctxDebug ctx) $+ label ++ " " ++ dump cr ++ " " ++ dump (convert key) where- dump = init . tail . showBytesHex+ dump = init . drop 1 . showBytesHex
− Network/TLS/Handshake/Process.hs
@@ -1,35 +0,0 @@--- |--- process handshake message received-module Network.TLS.Handshake.Process (- processHandshake12,- processHandshake13,- startHandshake,-) where--import Control.Concurrent.MVar--import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Sending-import Network.TLS.Struct-import Network.TLS.Struct13--processHandshake12 :: Context -> Handshake -> IO ()-processHandshake12 ctx hs = do- when (isHRR hs) $ usingHState ctx wrapAsMessageHash13- void $ updateHandshake12 ctx hs- where- isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand- isHRR _ = False--processHandshake13 :: Context -> Handshake13 -> IO ()-processHandshake13 ctx = void . updateHandshake13 ctx---- initialize a new Handshake context (initial handshake or renegotiations)-startHandshake :: Context -> Version -> ClientRandom -> IO ()-startHandshake ctx ver crand =- let hs = Just $ newEmptyHandshake ver crand- in void $ swapMVar (ctxHandshakeState ctx) hs
Network/TLS/Handshake/Random.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} module Network.TLS.Handshake.Random ( serverRandom,+ serverRandomECH,+ replaceServerRandomECH, clientRandom,- hrrRandom,- isHelloRetryRequest, isDowngraded, ) where import qualified Data.ByteString as B+ import Network.TLS.Context.Internal+import Network.TLS.Imports import Network.TLS.Struct -- | Generate a server random suitable for the version selected by the server@@ -36,6 +39,17 @@ pref <- getStateRNG ctx 24 return (pref `B.append` suff) +serverRandomECH :: Context -> IO ServerRandom+serverRandomECH ctx = do+ rnd <- getStateRNG ctx 24+ let zeros = "\x00\x00\x00\x00\x00\x00\x00\x00"+ return $ ServerRandom (rnd <> zeros)++replaceServerRandomECH :: ServerRandom -> ByteString -> ServerRandom+replaceServerRandomECH (ServerRandom rnd) bs = ServerRandom (rnd' <> bs)+ where+ rnd' = B.take 24 rnd+ -- | Test if the negotiated version was artificially downgraded (that is, for -- other reason than the versions supported by the client). isDowngraded :: Version -> [Version] -> ServerRandom -> Bool@@ -49,52 +63,11 @@ suffix11 `B.isSuffixOf` sr | otherwise = False -suffix12 :: B.ByteString-suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01]+suffix12 :: ByteString+suffix12 = "\x44\x4F\x57\x4E\x47\x52\x44\x01" -suffix11 :: B.ByteString-suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00]+suffix11 :: ByteString+suffix11 = "\x44\x4F\x57\x4E\x47\x52\x44\x00" clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32--hrrRandom :: ServerRandom-hrrRandom =- ServerRandom $- B.pack- [ 0xCF- , 0x21- , 0xAD- , 0x74- , 0xE5- , 0x9A- , 0x61- , 0x11- , 0xBE- , 0x1D- , 0x8C- , 0x02- , 0x1E- , 0x65- , 0xB8- , 0x91- , 0xC2- , 0xA2- , 0x11- , 0x16- , 0x7A- , 0xBB- , 0x8C- , 0x5E- , 0x07- , 0x9E- , 0x09- , 0xE2- , 0xC8- , 0xA8- , 0x33- , 0x9C- ]--isHelloRetryRequest :: ServerRandom -> Bool-isHelloRetryRequest = (== hrrRandom)
Network/TLS/Handshake/Server.hs view
@@ -4,11 +4,13 @@ handshakeServer, handshakeServerWith, requestCertificateServer,- postHandshakeAuthServerWith,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where -import Control.Exception (bracket) import Control.Monad.State.Strict+import Data.Maybe import Network.TLS.Context.Internal import Network.TLS.Handshake.Common@@ -20,12 +22,8 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13-import Network.TLS.IO import Network.TLS.Imports-import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types -- Put the server context in handshake mode. --@@ -35,57 +33,57 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do- hss <- recvPacketHandshake ctx- case hss of- [ch] -> handshake sparams ctx ch- _ -> unexpected (show hss) (Just "client hello")+ hbs <- recvPacketHandshake ctx+ case hbs of+ chb : _ -> handshake sparams ctx chb+ _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()+handshakeServerWith+ :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter.--- This is useful when the client hello has been already poped from the recv layer to inspect the packet.+-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. ----- When the function returns, a new handshake has been succesfully negociated.+-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised.-handshake :: ServerParams -> Context -> Handshake -> IO ()-handshake sparams ctx clientHello = do- (chosenVersion, ch) <- processClientHello sparams ctx clientHello+handshake :: ServerParams -> Context -> HandshakeR -> IO ()+handshake sparams ctx chb@(ClientHello ch, bs) = do+ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry.- (mClientKeyShare, r0) <-- processClientHello13 sparams ctx ch- case mClientKeyShare of- Nothing -> do- sendHRR ctx r0 ch+ -- r0 :: Cipher, Hash, Bool+ (keyShareResult, r0, r1) <-+ processClientHello13 sparams ctx chI+ case keyShareResult of+ SelectKeyShareNotFound ->+ throwCore $+ Error_Protocol "no group in common with the client for HRR" HandshakeFailure+ SelectKeyShareHRR g -> do+ sendHRR ctx g r0 chI $ isJust mcrnd+ -- Don't reset ctxEstablished since 0-RTT data+ -- would be coming, which should be ignored. handshakeServer sparams ctx- Just cliKeyShare -> do- r1 <-- sendServerHello13 sparams ctx cliKeyShare r0 ch- recvClientSecondFlight13 sparams ctx r1 ch+ SelectKeyShareFound cliKeyShare -> do+ unless (checkClientKeyShareKeyLength cliKeyShare) $+ throwCore $+ Error_Protocol "broken key_share" IllegalParameter+ -- r2 :: ( SecretTriple ApplicationSecret+ -- , ClientTrafficSecret HandshakeSecret+ -- , Bool -- authenticated+ -- , Bool) -- rtt0OK+ r2 <-+ sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd+ recvClientSecondFlight13 sparams ctx r2 chI else do r <-- processClinetHello12 sparams ctx ch+ processClientHello12 sparams ctx chI+ updateTranscriptHash12 ctx chb resumeSessionData <-- sendServerHello12 sparams ctx r ch+ sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData--newCertReqContext :: Context -> IO CertReqContext-newCertReqContext ctx = getStateRNG ctx 32--requestCertificateServer :: ServerParams -> Context -> IO Bool-requestCertificateServer sparams ctx = do- tls13 <- tls13orLater ctx- supportsPHA <- usingState_ ctx getClientSupportsPHA- let ok = tls13 && supportsPHA- when ok $ do- certReqCtx <- newCertReqContext ctx- let certReq = makeCertRequest sparams ctx certReqCtx- bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- addCertRequest13 ctx certReq- sendPacket13 ctx $ Handshake13 [certReq]- return ok+handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -1,22 +1,41 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module Network.TLS.Handshake.Server.ClientHello ( processClientHello, ) where +import qualified Control.Exception as E+import Crypto.HPKE+import qualified Data.ByteString as BS++import Network.TLS.ECH.Config++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.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement+import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Types processClientHello- :: ServerParams -> Context -> Handshake -> IO (Version, CH)-processClientHello sparams ctx clientHello@(ClientHello legacyVersion cran compressions ch@CH{..}) = do+ :: ServerParams+ -> Context+ -> ClientHello+ -> [ByteString]+ -> IO+ ( Version+ , ClientHello+ , Maybe ClientRandom -- Just for ECH to keep the outer one for key log+ )+processClientHello sparams ctx ch@CH{..} b = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do@@ -28,8 +47,7 @@ eof <- ctxEOF ctx let renegotiation = established == Established && not eof when- ( renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)- )+ (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $ throwCore $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation -- check if policy allow this new handshake to happens@@ -39,30 +57,26 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - -- Handle Client hello- hrr <- usingState_ ctx getTLS13HRR- unless hrr $ startHandshake ctx legacyVersion cran- processHandshake12 ctx clientHello-- when (legacyVersion /= TLS12) $+ when (chVersion /= TLS12) $ throwCore $- Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion+ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when ( supportedFallbackScsv (ctxSupported ctx)- && (0x5600 `elem` chCiphers)- && legacyVersion < TLS12+ && (CipherId 0x5600 `elem` chCiphers)+ && chVersion < 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 == []- _ -> []- clientVersion = min TLS12 legacyVersion+ let extract (SupportedVersionsClientHello vers) = vers -- fixme: vers == []+ extract _ = []+ clientVersions =+ lookupAndDecode EID_SupportedVersions MsgTClientHello chExtensions [] extract+ clientVersion = min TLS12 chVersion serverVersions | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx@@ -86,24 +100,80 @@ ProtocolVersion 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+ -- Checking compression+ let nullComp = compressionID nullCompression+ case chosenVersion of+ TLS13 ->+ when (chComps /= [nullComp]) $+ throwCore $+ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter+ _ -> case find (== nullComp) chComps of+ Nothing ->+ throwCore $+ Error_Protocol+ "compressions must include nullCompression in TLS 1.2"+ IllegalParameter+ _ -> return ()++ -- Processing encrypted client hello+ (mClientHello', receivedECH) <-+ if chosenVersion == TLS13 && not (null (serverECHKey sparams))+ then do+ lookupAndDecodeAndDo+ EID_EncryptedClientHello+ MsgTClientHello+ chExtensions+ (return (Nothing, False))+ (\bs -> (,True) <$> decryptECH sparams ctx ch bs)+ else return (Nothing, False)+ case mClientHello' of+ Just chI -> do+ -- chI is created from diff.+ -- encodeHandshake is a MUST.+ setupI ctx chI $ [encodeHandshake $ ClientHello chI]+ return (chosenVersion, chI, Just chRandom)+ _ -> do+ setupO ctx ch b+ when (chosenVersion == TLS13) $ do+ let hasECHConf = not (null (sharedECHConfigList (serverShared sparams)))+ when (hasECHConf && not receivedECH) $+ usingHState ctx $+ setECHEE True+ when receivedECH $+ usingHState ctx $+ setECHEE True+ return (chosenVersion, ch, Nothing)++setupI :: Context -> ClientHello -> [ByteString] -> IO ()+setupI ctx chI@CH{..} b = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx TLS13 chRandom+ usingHState ctx $ setClientHello chI b+ let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName- return (chosenVersion, ch)-processClientHello _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in handshakeServerWith"- HandshakeFailure +setupO :: Context -> ClientHello -> [ByteString] -> IO ()+setupO ctx ch@CH{..} b = do+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx chVersion chRandom+ usingHState ctx $ setClientHello ch b+ let serverName = getServerName chExtensions+ maybe (return ()) (usingState_ ctx . setClientSNI) serverName++-- SNI (Server Name Indication)+getServerName :: [ExtensionRaw] -> Maybe HostName+getServerName chExts =+ lookupAndDecode+ EID_ServerName+ MsgTClientHello+ chExts+ Nothing+ extractServerName+ where+ extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns)+ toHostName (ServerNameHostName hostName) = Just hostName+ toHostName (ServerNameOther _) = Nothing+ findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of@@ -117,3 +187,119 @@ where svs = sortOn Down serverVersions cvs = sortOn Down $ filter (>= TLS12) clientVersions++decryptECH+ :: ServerParams+ -> Context+ -> ClientHello+ -> EncryptedClientHello+ -> IO (Maybe ClientHello)+decryptECH _ _ _ ECHClientHelloInner = return Nothing+decryptECH sparams ctx chO ech@ECHClientHelloOuter{..} = E.handle hpkeHandler $ do+ mfunc <- getHPKE sparams ctx ech+ case mfunc of+ Nothing -> return Nothing+ Just (func, nenc) -> do+ hrr <- usingState_ ctx getTLS13HRR+ let nenc' = if hrr then 0 else nenc+ let aad = encodeHandshake' $ ClientHello $ fill0ClientHello nenc' chO+ plaintext <- func aad echPayload+ case decodeClientHello' plaintext of+ Right (ClientHello chI) -> do+ case expandClientHello chI chO of+ Nothing -> return Nothing+ Just chI' -> return $ Just chI'+ _ -> return Nothing+ where+ hpkeHandler :: HPKEError -> IO (Maybe ClientHello)+ hpkeHandler _ = return Nothing+decryptECH _ _ _ _ = return Nothing++fill0ClientHello :: Int -> ClientHello -> ClientHello+fill0ClientHello nenc ch@CH{..} =+ ch{chExtensions = fill0Exts nenc chExtensions}++fill0Exts :: Int -> [ExtensionRaw] -> [ExtensionRaw]+fill0Exts nenc xs0 = loop xs0+ where+ loop [] = []+ loop (ExtensionRaw EID_EncryptedClientHello bs : xs) = x' : loop xs+ where+ (prefix, payload) = BS.splitAt (10 + nenc) bs+ bs' = prefix <> BS.replicate (BS.length payload) 0+ x' = ExtensionRaw EID_EncryptedClientHello bs'+ loop (x : xs) = x : loop xs++expandClientHello :: ClientHello -> ClientHello -> Maybe ClientHello+expandClientHello inner outer =+ case expand (chExtensions inner) (chExtensions outer) of+ Nothing -> Nothing+ Just exts ->+ Just $+ inner+ { chSession = chSession outer+ , chExtensions = exts+ }+ where+ expand :: [ExtensionRaw] -> [ExtensionRaw] -> Maybe [ExtensionRaw]+ expand [] _ = Just []+ expand iis [] = chk iis+ expand (i : is) oos = do+ (rs, oos') <- case i of+ ExtensionRaw EID_EchOuterExtensions bs ->+ case extensionDecode MsgTClientHello bs of+ Nothing -> Nothing+ Just (EchOuterExtensions eids) -> expd eids oos+ _ -> Just ([i], oos)+ (rs ++) <$> expand is oos'+ expd+ :: [ExtensionID] -> [ExtensionRaw] -> Maybe ([ExtensionRaw], [ExtensionRaw])+ expd [] oos = Just ([], oos)+ expd _ [] = Nothing+ expd (i : is) oos = case fnd i oos of+ Nothing -> Nothing+ Just (ext, oos') -> do+ (exts, oos'') <- expd is oos'+ Just (ext : exts, oos'')+ fnd :: ExtensionID -> [ExtensionRaw] -> Maybe (ExtensionRaw, [ExtensionRaw])+ fnd _ [] = Nothing+ fnd EID_EncryptedClientHello _ = Nothing+ fnd i (o@(ExtensionRaw eid _) : os)+ | i == eid = Just (o, os)+ | otherwise = fnd i os+ chk :: [ExtensionRaw] -> Maybe [ExtensionRaw]+ chk [] = Just []+ chk (ExtensionRaw EID_EchOuterExtensions _ : _) = Nothing+ chk (i : is) = (i :) <$> chk is++getHPKE+ :: ServerParams+ -> Context+ -> EncryptedClientHello+ -> IO (Maybe (HPKEF, Int))+getHPKE ServerParams{..} ctx ECHClientHelloOuter{..} = do+ mfunc <- getTLS13HPKE ctx+ case mfunc of+ Nothing -> do+ let mconfig = findECHConfigById echConfigId $ sharedECHConfigList serverShared+ mskR = lookup echConfigId serverECHKey+ case (mconfig, mskR) of+ (Just config, Just skR') -> do+ let kemid = KEM_ID $ kem_id $ key_config $ contents config+ skR = EncodedSecretKey skR'+ encodedConfig = encodeECHConfig config+ let info = "tls ech\x00" <> encodedConfig+ (kdfid, aeadid) = echCipherSuite+ ctxR <- setupBaseR kemid kdfid aeadid skR Nothing echEnc info+ let nenc = nEnc kemid+ func = open ctxR+ setTLS13HPKE ctx func nenc+ return $ Just (func, nenc)+ _ -> return Nothing+ _ -> return mfunc+getHPKE _ _ _ = return Nothing++findECHConfigById :: ConfigId -> ECHConfigList -> Maybe ECHConfig+findECHConfigById cnfId echConfigList = find eqCfgId echConfigList+ where+ eqCfgId cnf = config_id (key_config (contents cnf)) == cnfId
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -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+ -> ClientHello -> 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 -> ClientHello -> 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,23 @@ credsTriple :: ServerParams- -> Context- -> CH+ -> ClientHello -> 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++ p = makeCredentialPredicate TLS12 chExtensions allCreds =- filterCredentials (isCredentialAllowed TLS12 chExtensions) $- extraCreds `mappend` sharedCredentials (ctxShared ctx)+ filterCredentials (isCredentialAllowed TLS12 p) $+ 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@@ -95,10 +101,12 @@ -- Cipher selection is performed in two steps: first server credentials -- are flagged as not suitable for signature if not compatible with- -- negotiated signature parameters. Then ciphers are evalutated from+ -- negotiated signature parameters. Then ciphers are evaluated 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 +129,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 +171,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 +208,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
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -3,32 +3,40 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13,- sendHRR,+ SelectKeyShareResult (..), ) where +import qualified Data.ByteString as B+ import Network.TLS.Cipher 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.Signature import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.IO+import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters+import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct-import Network.TLS.Struct13+import Network.TLS.Types +limitSupportedGroups :: Int+limitSupportedGroups = 64+ -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context- -> CH- -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool))-processClientHello13 sparams ctx CH{..} = do+ -> ClientHello+ -> IO+ ( SelectKeyShareResult+ , (Cipher, Hash, Bool) -- rtt0+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ )+processClientHello13 sparams ctx ch@CH{..} = do when (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) $ throwCore@@ -42,78 +50,163 @@ 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- 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 ->+ rtt0 =+ lookupAndDecode+ EID_EarlyData+ MsgTClientHello+ chExtensions+ False+ (\(EarlyDataIndication _) -> True)+ if rtt0+ then+ -- mark a 0-RTT attempt before a possible HRR, and before updating the+ -- status again if 0-RTT successful+ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ else+ -- In the case of HRR, EarlyDataNotAllowed is already set.+ -- It should be cleared here.+ setEstablished ctx NotEstablished+ -- Deciding key exchange from key shares+ let require = throwCore $ Error_Protocol "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- mshare <- findKeyShare keyShares serverGroups- return (mshare, (usedCipher, usedHash, rtt0))+ extract (KeyShareClientHello kses) = return kses+ extract _ = require+ keyShares <-+ lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract+ let clientGroups =+ take limitSupportedGroups $+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExtensions+ []+ (\(SupportedGroups gs) -> gs)+ (mgroup, doHRR) <-+ onSelectKeyShare+ (serverHooks sparams)+ serverGroups+ clientGroups+ $ map keyShareEntryGroup keyShares+ keyshareResult <- case mgroup of+ Nothing -> return SelectKeyShareNotFound+ Just g+ | doHRR -> return $ SelectKeyShareHRR g+ | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of+ [] -> return SelectKeyShareNotFound+ [x] -> return $ SelectKeyShareFound x+ _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter++ let triple = (usedCipher, usedHash, rtt0)+ pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch+ (ich, b) <- fromJust <$> usingHState ctx getClientHello+ updateTranscriptHash12 ctx (ClientHello ich, b)+ return (keyshareResult, triple, pskEarlySecret) where- ciphersFilteredVersion = filter ((`elem` chCiphers) . cipherID) serverCiphers+ ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) (supportedCiphers $ serverSupported sparams)- serverGroups = supportedGroups (ctxSupported ctx)+ serverGroups = supportedGroupsTLS13 $ serverSupported sparams -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)-findKeyShare ks ggs = go ggs+data SelectKeyShareResult+ = -- | Negotiation failure+ SelectKeyShareNotFound+ | -- | Send a hello retry request with this group+ SelectKeyShareHRR Group+ | -- | Use this key share+ SelectKeyShareFound KeyShareEntry+ deriving (Eq, Show)++pskAndEarlySecret+ :: ServerParams+ -> Context+ -> (Cipher, Hash, Bool) -- rtt0+ -> ClientHello+ -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do+ (psk, binderInfo, is0RTTvalid) <- choosePSK+ earlyKey <- calculateEarlySecret ctx choice (Left psk)+ let earlySecret = pairBase earlyKey+ authenticated = isJust binderInfo+ preSharedKeyExt <- checkBinder earlySecret binderInfo+ return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) where- go [] = return Nothing- go (g : gs) = case filter (grpEq g) ks of- [] -> go gs- [k] -> do- unless (checkKeyShareKeyLength k) $- throwCore $- Error_Protocol "broken key_share" IllegalParameter- return $ Just k- _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter- grpEq g ent = g == keyShareEntryGroup ent+ choice = makeCipherChoice TLS13 usedCipher -sendHRR :: Context -> (Cipher, a, b) -> CH -> IO ()-sendHRR ctx (usedCipher, _, _) CH{..} = do- twice <- usingState_ ctx getTLS13HRR- when twice $- throwCore $- 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 -> []- possibleGroups = serverGroups `intersect` clientGroups- case possibleGroups of- [] ->+ choosePSK =+ lookupAndDecodeAndDo+ EID_PreSharedKey+ MsgTClientHello+ chExtensions+ (return (zero, Nothing, False))+ selectPSK++ selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do+ when (null dhModes) $ throwCore $- Error_Protocol "no group in common with the client for HRR" HandshakeFailure- g : _ -> do- let serverKeyShare = extensionEncode $ KeyShareHRR g- selectedVersion = extensionEncode $ SupportedVersionsServerHello TLS13- extensions =- [ ExtensionRaw EID_KeyShare serverKeyShare- , ExtensionRaw EID_SupportedVersions selectedVersion- ]- hrr = ServerHello13 hrrRandom chSession (cipherID usedCipher) extensions- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [hrr]- sendChangeCipherSpec13 ctx- where- serverGroups = supportedGroups (ctxSupported ctx)+ 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)++ checkBinder _ Nothing = return []+ checkBinder earlySecret (Just (binder, n, tlen)) = do+ (_, b) <- fromJust <$> usingHState ctx getClientHello+ let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx+ unless (binder == binder') $+ decryptError "PSK binder validation failed"+ return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]++ checkSessionEquality sdata = do+ msni <- usingState_ ctx getClientSNI+ -- ALPN should be checked.+ -- But it's an extension in EE, sigh.+ -- malpn <- usingState_ ctx getNegotiatedProtocol+ let isSameSNI = sessionClientSNI sdata == msni+ isSameCipher = sessionCipher sdata == cipherID usedCipher+ ciphers = supportedCiphers $ serverSupported sparams+ scid = sessionCipher sdata+ isSameKDF = case findCipher scid ciphers of+ Nothing -> False+ Just c -> cipherHash c == cipherHash usedCipher+ isSameVersion = TLS13 == sessionVersion sdata+ -- isSameALPN = sessionALPN sdata == malpn+ isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required+ is0RTTvalid = isSameVersion && isSameCipher -- && isSameALPN+ return (isPSKvalid, is0RTTvalid)++ dhModes =+ lookupAndDecode+ EID_PskKeyExchangeModes+ MsgTClientHello+ chExtensions+ []+ (\(PskKeyExchangeModes ms) -> ms)++ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0
Network/TLS/Handshake/Server/Common.hs view
@@ -7,12 +7,15 @@ credentialDigitalSignatureKey, filterCredentials, filterCredentialsWithHashSignatures,+ makeCredentialPredicate, isCredentialAllowed, storePrivInfoServer,+ hashAndSignaturesInCommon,+ processRecordSizeLimit, ) where import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS.Context.Internal import Network.TLS.Credentials@@ -50,20 +53,25 @@ filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials filterCredentials p (Credentials l) = Credentials (filter p l) -isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool-isCredentialAllowed ver exts cred =+-- ECDSA keys are tested against supported elliptic curves until TLS12 but+-- not after. With TLS13, the curve is linked to the signature algorithm+-- and client support is tested with signatureCompatible13.+makeCredentialPredicate :: Version -> [ExtensionRaw] -> (Group -> Bool)+makeCredentialPredicate ver exts+ | ver >= TLS13 = const True+ | otherwise =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ exts+ (const True)+ (\(SupportedGroups sg) -> (`elem` sg))++isCredentialAllowed :: Version -> (Group -> Bool) -> Credential -> Bool+isCredentialAllowed ver p cred = pubkey `versionCompatible` ver && satisfiesEcPredicate p pubkey where (pubkey, _) = credentialPublicPrivateKeys cred- -- ECDSA keys are tested against supported elliptic curves until TLS12 but- -- not after. With TLS13, the curve is linked to the signature algorithm- -- and client support is tested with signatureCompatible13.- p- | ver < TLS13 = case extensionLookup EID_SupportedGroups exts- >>= extensionDecode MsgTClientHello of- Nothing -> const True- Just (SupportedGroups sg) -> (`elem` sg)- | otherwise = const True -- Filters a list of candidate credentials with credentialMatchesHashSignatures. --@@ -86,42 +94,49 @@ 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+ let alpn = ApplicationLayerProtocolNegotiation [proto]+ return $ Just $ toExtensionRaw alpn clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () clientCertificate sparams ctx certs = do@@ -136,9 +151,57 @@ (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of- CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ CertificateUsageAccept -> do+ verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs CertificateUsageReject reason -> certificateRejected reason -- 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)++processRecordSizeLimit+ :: Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)+processRecordSizeLimit ctx chExts tls13 = do+ let mmylim = limitRecordSize $ sharedLimit $ ctxShared ctx+ setMyRecordLimit ctx mmylim+ case mmylim of+ Nothing -> return Nothing+ Just mylim -> do+ lookupAndDecodeAndDo+ EID_RecordSizeLimit+ MsgTClientHello+ chExts+ (return ())+ (setPeerRecordSizeLimit ctx tls13)+ peerSentRSL <- checkPeerRecordLimit ctx+ if peerSentRSL+ then do+ let mysiz = fromIntegral mylim + if tls13 then 1 else 0+ rsl = RecordSizeLimit mysiz+ return $ Just $ toExtensionRaw rsl+ else return Nothing
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -5,6 +5,8 @@ sendServerHello12, ) where +import Data.ByteArray (convert)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -31,63 +33,70 @@ :: ServerParams -> Context -> (Cipher, Maybe Credential)- -> CH+ -> ClientHello -> IO (Maybe SessionData) sendServerHello12 sparams ctx (usedCipher, mcred) ch@CH{..} = do resumeSessionData <- recoverSessionData ctx ch case resumeSessionData of Nothing -> do serverSession <- newSession ctx- usingState_ ctx $ setSession serverSession False- serverhello <-- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession+ usingState_ ctx $ setSession serverSession+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions- let ff = serverhello : build [ServerHelloDone]- sendPacket12 ctx $ Handshake ff+ let ff = ServerHello sh : build [ServerHelloDone]+ sendPacket12 ctx $ Handshake ff [] contextFlush ctx Just sessionData -> do- usingState_ ctx $ setSession chSession True- serverhello <-+ usingState_ ctx $ do+ setSession chSession+ setTLS12SessionResuming True+ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession- sendPacket12 ctx $ Handshake [serverhello]- let mainSecret = sessionSecret sessionData+ sendPacket12 ctx $ Handshake [ServerHello sh] []+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole return resumeSessionData -recoverSessionData :: Context -> CH -> IO (Maybe SessionData)+recoverSessionData :: Context -> ClientHello -> IO (Maybe SessionData) recoverSessionData ctx CH{..} = do serverName <- usingState_ ctx getClientSNI ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions let mticket =- extensionLookup EID_SessionTicket chExtensions- >>= extensionDecode MsgTClientHello- case mticket of- Just (SessionTicket ticket) | ticket /= "" -> do- sd <- sessionResume (sharedSessionManager $ ctxShared ctx) ticket- validateSession chCiphers serverName ems sd- _ -> case chSession of- (Session (Just clientSessionId)) -> do- sd <- sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId- validateSession chCiphers serverName ems sd- (Session Nothing) -> return Nothing+ 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 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 different 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"@@ -103,12 +112,12 @@ -> Maybe Credential -> [ExtensionRaw] -> IO ([Handshake] -> [Handshake])-sendServerFirstFlight sparams ctx usedCipher mcred chExts = do+sendServerFirstFlight ServerParams{..} ctx usedCipher mcred chExts = do let b0 = id let cc = case mcred of Just (srvCerts, _) -> srvCerts _ -> CertificateChain []- let b1 = b0 . (Certificate cc :)+ let b1 = b0 . (Certificate (CertificateChain_ cc) :) usingState_ ctx $ setServerCertificateChain cc -- send server key exchange if needed@@ -130,26 +139,28 @@ -- -- Client certificates MUST NOT be accepted if not requested. --- if serverWantClientCert sparams+ if serverWantClientCert then do let (certTypes, hashSigs) =- let as = supportedHashSignatures $ ctxSupported ctx+ let as = supportedHashSignatures serverSupported in (nub $ mapMaybe hashSigToCertType as, as) creq = CertRequest certTypes hashSigs- (map extractCAname $ serverCACertificates sparams)+ (map extractCAname serverCACertificates) usingHState ctx $ setCertReqSent True return $ b2 . (creq :) else return b2 where+ commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts+ commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts setup_DHE = do- let possibleFFGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableFFGroups+ let possibleFFGroups = commonGroups `intersect` availableFFGroups (dhparams, priv, pub) <- case possibleFFGroups of [] ->- let dhparams = fromJust $ serverDHEParams sparams+ let dhparams = fromJust serverDHEParams in case findFiniteFieldGroup dhparams of Just g -> do usingHState ctx $ setSupportedGroup g@@ -174,8 +185,7 @@ -- If RSA is also used for key exchange, this function is -- not called. decideHashSig pubKey = do- let hashSigs = hashAndSignaturesInCommon ctx chExts- case filter (pubKey `signatureCompatible`) hashSigs of+ case filter (pubKey `signatureCompatible`) commonHashSigs of [] -> error ("no hash signature for " ++ pubkeyType pubKey) x : _ -> return x @@ -194,14 +204,14 @@ setup_ECDHE grp = do usingHState ctx $ setSupportedGroup grp- (srvpri, srvpub) <- generateECDHE ctx grp+ (srvpri, srvpub) <- generateGroup ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams- usingHState ctx $ setGroupPrivate srvpri+ usingHState ctx $ setGroupPrivate [(grp, srvpri)] return serverParams generateSKX_ECDHE kxsAlg = do- let possibleECGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableECGroups+ let possibleECGroups = commonGroups `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure g : _ -> return g@@ -227,37 +237,15 @@ -> Maybe Credential -> [ExtensionRaw] -> Session- -> IO Handshake+ -> IO ServerHello makeServerHello sparams ctx usedCipher mcred chExts session = do- resuming <- usingState_ ctx isSessionResuming- srand <-- serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams+ resuming <- usingState_ ctx getTLS12SessionResuming case mcred of Just cred -> storePrivInfoServer ctx cred _ -> return () -- return a sensible error-- -- in TLS12, we need to check as well the certificates we are sending if they have in the extension- -- the necessary bits set.- secReneg <- usingState_ ctx getSecureRenegotiation- secRengExt <-- if secReneg- then do- vd <- usingState_ ctx $ do- cvd <- getVerifyData ClientRole- svd <- getVerifyData ServerRole- return $ extensionEncode $ SecureRenegotiation cvd svd- return [ExtensionRaw EID_SecureRenegotiation vd]- else return []- ems <- usingHState ctx getExtendedMainSecret- let emsExt- | ems =- let raw = extensionEncode ExtendedMainSecret- in [ExtensionRaw EID_ExtendedMainSecret raw]- | otherwise = []- protoExt <- applicationProtocol ctx chExts sparams sniExt <- do if resuming- then return []+ then return Nothing else do msni <- usingState_ ctx getClientSNI case msni of@@ -265,56 +253,73 @@ -- 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 ecPointExt = case extensionLookup EID_EcPointFormats chExts of+ Nothing -> Nothing+ Just _ -> Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]++ alpnExt <- applicationProtocol ctx chExts sparams++ ems <- usingHState ctx getExtendedMainSecret+ let emsExt+ | ems = Just $ toExtensionRaw ExtendedMainSecret+ | otherwise = Nothing+ let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams- ticktExt- | not resuming && useTicket =- let raw = extensionEncode $ SessionTicket ""- in [ExtensionRaw EID_SessionTicket raw]- | otherwise = []+ sessionTicketExt+ | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket ""+ | otherwise = Nothing++ -- in TLS12, we need to check as well the certificates we are sending if they have in the extension+ -- the necessary bits set.+ secReneg <- usingState_ ctx getSecureRenegotiation+ secureRenegExt <-+ if secReneg+ then do+ vd <- usingState_ ctx $ do+ VerifyData cvd <- getVerifyData ClientRole+ VerifyData svd <- getVerifyData ServerRole+ return $ SecureRenegotiation cvd svd+ return $ Just $ toExtensionRaw vd+ else return Nothing++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExts False++ srand <-+ serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams+ let shExts = sharedHelloExtensions (serverShared sparams)- ++ secRengExt- ++ emsExt- ++ protoExt- ++ sniExt- ++ ticktExt+ ++ catMaybes+ [ {- 0x00 -} sniExt+ , {- 0x0b -} ecPointExt+ , {- 0x10 -} alpnExt+ , {- 0x17 -} emsExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x23 -} sessionTicketExt+ , {- 0xff01 -} secureRenegExt+ ] usingState_ ctx $ setVersion TLS12- usingHState ctx $- setServerHelloParameters TLS12 srand usedCipher nullCompression+ setServerHelloParameters12 ctx TLS12 srand usedCipher nullCompression return $- ServerHello- TLS12- srand- session- (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+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = session+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ } -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 :: [Group] -> [ExtensionRaw] -> [Group]+negotiatedGroupsInCommon serverGroups chExts =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExts+ []+ common+ where+ common (SupportedGroups clientGroups) = serverGroups `intersect` clientGroups
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -3,10 +3,10 @@ module Network.TLS.Handshake.Server.ServerHello13 ( sendServerHello13,+ sendHRR, ) where import Control.Monad.State.Strict-import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -22,10 +22,10 @@ import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Parameters-import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -36,34 +36,46 @@ :: ServerParams -> Context -> KeyShareEntry- -> (Cipher, Hash, Bool)- -> CH+ -> (Cipher, Hash, Bool) -- rtt0+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid+ -> ClientHello+ -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret- , Bool- , Bool+ , Bool -- authenticated+ , Bool -- rtt0OK )-sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do+sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do+ let clientEarlySecret = pairClient earlyKey+ earlySecret = pairBase earlyKey+ -- parse CompressCertificate to check if it is broken here+ let zlib =+ lookupAndDecode+ EID_CompressCertificate+ MsgTClientHello+ chExtensions+ False+ (\(CompressCertificate ccas) -> CCA_Zlib `elem` ccas)++ recodeSizeLimitExt <- processRecordSizeLimit ctx chExtensions True+ enableMyRecordLimit ctx+ newSession ctx >>= \ss -> usingState_ ctx $ do- setSession ss False- setClientSupportsPHA supportsPHA- usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare- srand <- setServerParameter- -- ALPN is used in choosePSK- protoExt <- applicationProtocol ctx chExtensions sparams- (psk, binderInfo, is0RTTvalid) <- choosePSK- earlyKey <- calculateEarlySecret ctx choice (Left psk) True- let earlySecret = pairBase earlyKey- clientEarlySecret = pairClient earlyKey- extensions <- checkBinder earlySecret binderInfo+ setSession ss+ setTLS13ClientSupportsPHA supportsPHA+ usingHState ctx $ do+ setSupportedGroup $ keyShareEntryGroup clientKeyShare+ setOuterClientRandom mOuterClientRandom hrr <- usingState_ ctx getTLS13HRR- let authenticated = isJust binderInfo- rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ alpnExt <- applicationProtocol ctx chExtensions sparams+ setServerParameter+ let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)- let allCreds =- filterCredentials (isCredentialAllowed TLS13 chExtensions) $+ let p = makeCredentialPredicate TLS13 chExtensions+ allCreds =+ filterCredentials (isCredentialAllowed TLS13 p) $ extraCreds `mappend` sharedCredentials (ctxShared ctx) ---------------------------------------------------------------- established <- ctxEstablished ctx@@ -83,7 +95,7 @@ (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare ensureRecvComplete ctx (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do- sendServerHello keyShare srand extensions+ sendServerHello keyShare sendChangeCipherSpec13 ctx ---------------------------------------------------------------- handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe@@ -101,16 +113,17 @@ handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo ----------------------------------------------------------------- sendExtensions rtt0OK protoExt+ liftIO $ enablePeerRecordLimit ctx+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt case mCredInfo of Nothing -> return ()- Just (cred, hashSig) -> sendCertAndVerify cred hashSig+ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] return (clientHandshakeSecret, handSecret) ----------------------------------------------------------------- hChSf <- transcriptHash ctx+ hChSf <- transcriptHash ctx "CH..SF" appKey <- calculateApplicationSecret ctx choice handSecret hChSf let clientApplicationSecret0 = triClient appKey serverApplicationSecret0 = triServer appKey@@ -118,89 +131,36 @@ let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0, serverApplicationSecret0) contextSync ctx $ SendServerFinished appSecInfo ----------------------------------------------------------------- if rtt0OK- then setEstablished ctx (EarlyDataAllowed rtt0max)- else- when (established == NotEstablished) $- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max) return (appKey, clientHandshakeSecret, authenticated, rtt0OK) where choice = makeCipherChoice TLS13 usedCipher setServerParameter = do- srand <-- serverRandom ctx TLS13 $ supportedVersions $ serverSupported sparams usingState_ ctx $ setVersion TLS13- failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher- return srand-- supportsPHA = case extensionLookup EID_PostHandshakeAuth chExtensions- >>= extensionDecode MsgTClientHello of- Just PostHandshakeAuth -> True- Nothing -> False-- choosePSK = case extensionLookup EID_PreSharedKey chExtensions- >>= extensionDecode MsgTClientHello of- Just (PreSharedKeyClientHello (PskIdentity sessionId 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- msdata <-- if rtt0- then sessionResumeOnlyOnce mgr sessionId- else sessionResume mgr sessionId- 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)+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher False - 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- Nothing -> False- Just c -> cipherHash c == cipherHash usedCipher- isSameVersion = TLS13 == sessionVersion sdata- isSameALPN = sessionALPN sdata == malpn- isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required- is0RTTvalid = isSameVersion && isSameCipher && isSameALPN- return (isPSKvalid, is0RTTvalid)+ supportsPHA =+ lookupAndDecode+ EID_PostHandshakeAuth+ MsgTClientHello+ chExtensions+ False+ (\PostHandshakeAuth -> True) rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams rtt0accept = serverEarlyDataSize sparams > 0 - checkBinder _ Nothing = return []- checkBinder earlySecret (Just (binder, n, tlen)) = do- 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]- 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@@ -215,76 +175,117 @@ mcs -> return mcs 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- : extensions- helo = ServerHello13 srand chSession (cipherID usedCipher) extensions'- loadPacket13 ctx $ Handshake13 [helo]+ sendServerHello keyShare = do+ let keyShareExt = toExtensionRaw $ KeyShareServerHello keyShare+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ shExts = keyShareExt : versionExt : preSharedKeyExt+ if isJust mOuterClientRandom+ then do+ srand <- liftIO $ serverRandomECH ctx+ let cipherId = CipherId (cipherID usedCipher)+ sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ suffix <- computeConfirm ctx usedHash sh "ech accept confirmation"+ let srand' = replaceServerRandomECH srand suffix+ sh' =+ SH+ { shVersion = TLS12+ , shRandom = srand'+ , shSession = chSession+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = shExts+ }+ usingHState ctx $ setECHAccepted True+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] []+ else do+ srand <-+ liftIO $+ serverRandom ctx TLS13 $+ supportedVersions $+ serverSupported sparams+ let sh =+ SH+ { shVersion = TLS12+ , shRandom = srand+ , shSession = chSession+ , shCipher = CipherId (cipherID usedCipher)+ , shComp = 0+ , shExtensions = shExts+ }+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh] [] - sendCertAndVerify cred@(certChain, _) hashSig = do+ sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here.- certReq = makeCertRequest sparams ctx certReqCtx- loadPacket13 ctx $ Handshake13 [certReq]+ certReq = makeCertRequest sparams ctx certReqCtx True+ loadPacket13 ctx $ Handshake13 [certReq] [] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) []- loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess]+ let certtag = if zlib then CompressedCertificate13 else Certificate13+ loadPacket13 ctx $+ Handshake13 [certtag "" (CertificateChain_ certChain) ess] [] liftIO $ usingState_ ctx $ setServerCertificateChain certChain- hChSc <- transcriptHash ctx+ hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc- loadPacket13 ctx $ Handshake13 [vrfy]+ loadPacket13 ctx $ Handshake13 [vrfy] [] - sendExtensions rtt0OK protoExt = do+ sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI- let sniExtension = case msni of+ let sniExt = case msni of -- RFC6066: In this event, the server SHALL include -- an extension of type "server_name" in the -- (extended) server hello. The "extension_data" -- field of this extension SHALL be empty.- Just _ -> Just $ 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)- let earlyDataExtension- | rtt0OK =+ groupExt = case serverGroups of+ [] -> Nothing+ rg : _ -> case mgroup of+ Nothing -> Nothing+ Just grp+ | grp == rg -> Nothing+ | otherwise -> Just $ toExtensionRaw $ SupportedGroups serverGroups+ let earlyDataExt+ | rtt0OK = Just $ toExtensionRaw $ EarlyDataIndication Nothing+ | otherwise = Nothing++ sendECH <- usingHState ctx getECHEE+ let echExt+ | sendECH = Just $- ExtensionRaw EID_EarlyData $- extensionEncode (EarlyDataIndication Nothing)+ toExtensionRaw $+ ECHEncryptedExtensions $+ sharedECHConfigList $+ serverShared sparams | otherwise = Nothing- let extensions =+ let eeExtensions = sharedHelloExtensions (serverShared sparams) ++ catMaybes- [ earlyDataExtension- , groupExtension- , sniExtension+ [ {- 0x00 -} sniExt+ , {- 0x0a -} groupExt+ , {- 0x10 -} alpnExt+ , {- 0x1c -} recodeSizeLimitExt+ , {- 0x2a -} earlyDataExt+ , {- 0xfe0d -} echExt ]- ++ 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 -> []-- hashSize = hashDigestSize usedHash- zero = B.replicate hashSize 0+ eeExtensions' <-+ liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]@@ -309,3 +310,58 @@ contextSync :: Context -> ServerState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync _ sync -> sync ctx ctl++----------------------------------------------------------------++sendHRR :: Context -> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()+sendHRR ctx g (usedCipher, usedHash, _) CH{..} isEch = do+ twice <- usingState_ ctx getTLS13HRR+ when twice $+ throwCore $+ Error_Protocol "Hello retry not allowed again" HandshakeFailure+ usingState_ ctx $ setTLS13HRR True+ failOnEitherError $ setServerHelloParameters13 ctx usedCipher True+ hrr <- makeHRR ctx usedCipher usedHash chSession g isEch+ usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+ runPacketFlight ctx $ do+ loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] []+ sendChangeCipherSpec13 ctx++makeHRR+ :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello+makeHRR _ usedCipher _ session g False = return hrr+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ extensions = [keyShareExt, versionExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }+makeHRR ctx usedCipher usedHash session g True = do+ suffix <- computeConfirm ctx usedHash hrr "hrr ech accept confirmation"+ let echExt' = toExtensionRaw $ ECHHelloRetryRequest suffix+ extensions' = [keyShareExt, versionExt, echExt']+ hrr' = hrr{shExtensions = extensions'}+ return hrr'+ where+ keyShareExt = toExtensionRaw $ KeyShareHRR g+ versionExt = toExtensionRaw $ SupportedVersionsServerHello TLS13+ echExt = toExtensionRaw $ ECHHelloRetryRequest "\x00\x00\x00\x00\x00\x00\x00\x00"+ extensions = [keyShareExt, versionExt, echExt]+ cipherId = CipherId $ cipherID usedCipher+ hrr =+ SH+ { shVersion = TLS12+ , shRandom = hrrRandom+ , shSession = session+ , shCipher = cipherId+ , shComp = 0+ , shExtensions = extensions+ }
Network/TLS/Handshake/Server/TLS12.hs view
@@ -5,6 +5,7 @@ ) where import Control.Monad.State.Strict (gets)+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal@@ -40,12 +41,12 @@ Nothing -> return () Just ticket -> do let life = adjustLifetime $ serverTicketLifetime sparams- sendPacket12 ctx $ Handshake [NewSessionTicket life ticket]+ sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] [] sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx recvCCSandFinished ctx- handshakeDone12 ctx+ finishHandshake12 ctx where adjustLifetime i | i < 0 = 0@@ -60,6 +61,11 @@ Session (Just sessionId) -> do sessionData <- getSessionData ctx let sessionId' = B.copy sessionId+ -- SessionID method: SessionID is used as key to store+ -- SessionData. Nothing is returned.+ --+ -- Session ticket method: SessionID is ignored. SessionData+ -- is encrypted and returned. sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId'@@ -78,7 +84,7 @@ recvClientCCC :: ServerParams -> Context -> IO () recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate) where- expectClientCertificate (Certificate certs) = do+ expectClientCertificate (Certificate (CertificateChain_ certs)) = do clientCertificate sparams ctx certs processCertificate ctx ServerRole certs @@ -117,6 +123,7 @@ expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO) expectChangeCipherSpec ctx ChangeCipherSpec = do+ enableMyRecordLimit ctx return $ RecvStateHandshake $ expectFinished ctx expectChangeCipherSpec _ p = unexpected (show p) (Just "change cipher") @@ -130,15 +137,18 @@ (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 $ convert preMain of+ Left _ -> usingHState ctx $ setMainSecretFromPre rver role $ convert random+ Right (ver, _)+ | ver /= expectedVer ->+ usingHState ctx $ setMainSecretFromPre rver role $ convert random+ | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion@@ -156,21 +166,23 @@ logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams- case decodeGroupPublic grp bytes of+ case groupDecodePublicB grp bytes of Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter Right clipub -> do- srvpri <- usingHState ctx getGroupPrivate- case groupGetShared clipub srvpri of- Just preMain -> do- rver <- usingState_ ctx getVersion- role <- usingState_ ctx getRole- mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain- logKey ctx (MainSecret mainSecret)- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter+ grpSpris <- usingHState ctx getGroupPrivate+ case lookup grp grpSpris of+ Nothing -> throwCore err+ Just srvpri -> case groupDecapsulate clipub srvpri of+ Just preMain -> do+ rver <- usingState_ ctx getVersion+ role <- usingState_ ctx getRole+ mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain+ logKey ctx (MainSecret mainSecret)+ Nothing -> throwCore err+ where+ err = Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter ----------------------------------------------------------------
Network/TLS/Handshake/Server/TLS13.hs view
@@ -3,32 +3,42 @@ module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13,- postHandshakeAuthServerWith,+ requestCertificateServer,+ keyUpdate,+ updateKey,+ KeyUpdateRequest (..), ) where +import Control.Exception import Control.Monad.State.Strict+import Data.IORef import Network.TLS.Cipher import Network.TLS.Context.Internal+import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common hiding (expectFinished) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Key-import Network.TLS.Handshake.Process import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13+import Network.TLS.Handshake.TranscriptHash import Network.TLS.IO import Network.TLS.Imports+import Network.TLS.KeySchedule import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types+import Network.TLS.Util import Network.TLS.X509 +----------------------------------------------------------------+ recvClientSecondFlight13 :: ServerParams -> Context@@ -37,7 +47,7 @@ , Bool , Bool )- -> CH+ -> ClientHello -> IO () recvClientSecondFlight13 sparams ctx (appKey, clientHandshakeSecret, authenticated, rtt0OK) CH{..} = do sfSentTime <- getCurrentTimeFromBase@@ -45,9 +55,15 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime if not authenticated && serverWantClientCert sparams then runRecvHandshake13 $ do+ -- RFC 8446 Sec 4.4.3: Clients MUST send this message+ -- whenever authenticating via a certificate (i.e., when the+ -- Certificate message is non-empty). When sent, this message MUST+ -- appear immediately after the Certificate message and immediately+ -- prior to the Finished message. skip <- recvHandshake13 ctx $ expectCertificate sparams ctx- unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx)- recvHandshake13hash ctx expectFinished'+ unless skip $+ recvHandshake13hash ctx "CertVerify" (expectCertVerify sparams ctx)+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx else if rtt0OK && not (ctxQUICMode ctx)@@ -59,7 +75,7 @@ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ] else runRecvHandshake13 $ do- recvHandshake13hash ctx expectFinished'+ recvHandshake13hash ctx "Finished" expectFinished' ensureRecvComplete ctx expectFinished@@ -70,7 +86,7 @@ -> SecretTriple ApplicationSecret -> ClientTrafficSecret HandshakeSecret -> Word64- -> ByteString+ -> TranscriptHash -> Handshake13 -> m () expectFinished sparams ctx exts appKey clientHandshakeSecret sfSentTime hChBeforeCf (Finished13 verifyData) = liftIO $ do@@ -78,7 +94,7 @@ (usedHash, usedCipher, _, _) <- getRxRecordState ctx let ClientTrafficSecret chs = clientHandshakeSecret checkFinished ctx usedHash chs hChBeforeCf verifyData- handshakeDone13 ctx+ finishHandshake13 ctx setRxRecordState ctx usedHash usedCipher clientApplicationSecret0 sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime where@@ -87,7 +103,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") expectEndOfEarlyData- :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()+ :: Context+ -> ClientTrafficSecret HandshakeSecret+ -> Handshake13+ -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do (usedHash, usedCipher, _, _) <- getRxRecordState ctx setRxRecordState ctx usedHash usedCipher clientHandshakeSecret@@ -95,13 +114,20 @@ expectCertificate :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool-expectCertificate sparams ctx (Certificate13 certCtx certs _ext) = liftIO $ do+expectCertificate sparams ctx (Certificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs return $ isNullCertificateChain certs+expectCertificate sparams ctx (CompressedCertificate13 certCtx (CertificateChain_ certs) _ext) = liftIO $ do+ when (certCtx /= "") $+ throwCore $+ Error_Protocol "certificate request context MUST be empty" IllegalParameter+ -- fixme checking _ext+ clientCertificate sparams ctx certs+ return $ isNullCertificateChain certs expectCertificate _ _ hs = unexpected (show hs) (Just "certificate 13") sendNewSessionTicket@@ -115,13 +141,13 @@ sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime = when sendNST $ do cfRecvTime <- getCurrentTimeFromBase let rtt = cfRecvTime - sfSentTime- nonce <- getStateRNG ctx 32+ nonce <- TicketNonce <$> getStateRNG ctx 32 resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret let life = adjustLifetime $ serverTicketLifetime sparams psk = derivePSK choice resumptionSecret nonce (identity, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce identity rtt0max- sendPacket13 ctx $ Handshake13 [nst]+ sendPacket13 ctx $ Handshake13 [nst] [] where choice = makeCipherChoice TLS13 usedCipher rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams@@ -138,24 +164,28 @@ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk let mgr = sharedSessionManager $ serverShared sparams mticket <- sessionEstablish mgr sessionId sdata- let identity = fromMaybe sessionId mticket+ let identity = SessionIDorTicket_ $ fromMaybe sessionId mticket return (identity, ageAdd tinfo) createNewSessionTicket life add nonce identity maxSize =- NewSessionTicket13 life add nonce identity extensions+ NewSessionTicket13 life add nonce identity nstExtensions where- tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize- extensions = [ExtensionRaw EID_EarlyData tedi]+ nstExtensions+ | maxSize == 0 = []+ | otherwise = [earlyDataExt]+ where+ earlyDataExt = toExtensionRaw $ EarlyDataIndication $ Just $ fromIntegral maxSize adjustLifetime i | i < 0 = 0 | i > 604800 = 604800 | otherwise = fromIntegral i expectCertVerify- :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()-expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do+ :: MonadIO m+ => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()+expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <-- checkValidClientCertChain ctx "finished 13 message expected"+ checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure c : _ -> return $ certPubKey $ getCertificate c@@ -191,46 +221,167 @@ usingState_ ctx $ setClientCertificateChain certs else decryptError "verification failed" -postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do- mCertReq <- getCertRequest13 ctx certCtx- when (isNothing mCertReq) $- throwCore $- Error_Protocol "unknown certificate request context" DecodeError- let certReq = fromJust mCertReq+---------------------------------------------------------------- - -- fixme checking _ext- clientCertificate sparams ctx certs+newCertReqContext :: Context -> IO CertReqContext+newCertReqContext ctx = getStateRNG ctx 32 - baseHState <- saveHState ctx- processHandshake13 ctx certReq- processHandshake13 ctx h+requestCertificateServer :: ServerParams -> Context -> IO Bool+requestCertificateServer sparams ctx = handleEx ctx $ do+ tls13 <- tls13orLater ctx+ supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA+ let ok = tls13 && supportsPHA+ if ok+ then newIORef [] >>= sendCertReqAndRecv+ else return ok+ where+ sendCertReqAndRecv ref = do+ origCertReqCtx <- newCertReqContext ctx+ let certReq13 = makeCertRequest sparams ctx origCertReqCtx False+ _ <- withWriteLock ctx $ do+ bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+ sendPacket13 ctx $ Handshake13 [certReq13] []+ withReadLock ctx $ do+ (clientCert13, bClientCert13) <- getHandshake ctx ref+ emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13+ baseHState <- saveHState ctx+ updateTranscriptHash13 ctx (clientCert13, bClientCert13)+ th <- transcriptHash ctx "CH..Cert"+ unless emptyCert $ do+ (certVerify13, bCertVerify13) <- getHandshake ctx ref+ expectCertVerify sparams ctx th certVerify13+ updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+ (finished13, _bFinished13) <- getHandshake ctx ref+ expectClientFinished ctx finished13+ void $ restoreHState ctx baseHState -- fixme+ return True +-- saving appdata and key update?+-- error handling+getHandshake+ :: Context -> IORef [Handshake13R] -> IO Handshake13R+getHandshake ctx ref = do+ hhs <- readIORef ref+ if null hhs+ then do+ ex <- recvPacket13 ctx+ either (terminate ctx) process ex+ else chk hhs+ where+ process (Handshake13 hss bss) = chk $ zip hss bss+ process _ =+ terminate ctx $+ Error_Protocol "post handshake authenticated" UnexpectedMessage+ chk [] = getHandshake ctx ref+ chk ((KeyUpdate13 mode, _) : hbs) = do+ keyUpdate ctx getRxRecordState setRxRecordState+ -- Write lock wraps both actions because we don't want another+ -- packet to be sent by another thread before the Tx state is+ -- updated.+ when (mode == UpdateRequested) $ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] []+ keyUpdate ctx getTxRecordState setTxRecordState+ chk hbs+ chk (hb : hbs) = do+ writeIORef ref hbs+ return hb++expectClientCertificate+ :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool+expectClientCertificate sparams ctx origCertReqCtx (Certificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate sparams ctx origCertReqCtx (CompressedCertificate13 certReqCtx (CertificateChain_ certs) _ext) = do+ expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs+ return $ isNullCertificateChain certs+expectClientCertificate _ _ _ h = unexpected "Certificate" $ Just $ show h++expectClientCertificate'+ :: ServerParams+ -> Context+ -> CertReqContext+ -> CertReqContext+ -> CertificateChain+ -> IO ()+expectClientCertificate' sparams ctx origCertReqCtx certReqCtx certs = do+ when (origCertReqCtx /= certReqCtx) $+ throwCore $+ Error_Protocol "certificate context is wrong" IllegalParameter+ void $ clientCertificate sparams ctx certs++expectClientFinished :: Context -> Handshake13 -> IO ()+expectClientFinished ctx (Finished13 verifyData) = do (usedHash, _, level, applicationSecretN) <- getRxRecordState ctx unless (level == CryptApplicationSecret) $ throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError+ hChBeforeCf <- transcriptHash ctx "CH..<CF"+ checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData+expectClientFinished _ h = unexpected "Finished" $ Just $ show h - let expectFinished' hChBeforeCf (Finished13 verifyData) = do- checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData- void $ restoreHState ctx baseHState- expectFinished' _ hs = unexpected (show hs) (Just "finished 13")+terminate :: Context -> TLSError -> IO a+terminate ctx err = do+ let (level, desc) = errorToAlert err+ reason = errorToAlertMessage err+ send = sendPacket13 ctx . Alert13+ catchException (send [(level, desc)]) (\_ -> return ())+ setEOF ctx+ throwIO $ Terminated False reason err - -- Note: here the server could send updated NST too, however the library- -- currently has no API to handle resumption and client authentication- -- together, see discussion in #133- if isNullCertificateChain certs- then setPendingRecvActions ctx [PendingRecvActionHash False expectFinished']- else- setPendingRecvActions- ctx- [ PendingRecvActionHash False (expectCertVerify sparams ctx)- , PendingRecvActionHash False expectFinished'- ]-postHandshakeAuthServerWith _ _ _ =- throwCore $- Error_Protocol- "unexpected handshake message received in postHandshakeAuthServerWith"- UnexpectedMessage+handleEx :: Context -> IO Bool -> IO Bool+handleEx ctx f = catchException f $ \exception -> do+ -- If the error was an Uncontextualized TLSException, we replace the+ -- context with HandshakeFailed. If it's anything else, we convert+ -- it to a string and wrap it with Error_Misc and HandshakeFailed.+ let tlserror = case fromException exception of+ Just e | Uncontextualized e' <- e -> e'+ _ -> Error_Misc (show exception)+ sendPacket13 ctx $ Alert13 [errorToAlert tlserror]+ void $ throwIO $ PostHandshake tlserror+ return False++----------------------------------------------------------------++keyUpdate+ :: Context+ -> (Context -> IO (Hash, Cipher, CryptLevel, Secret))+ -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())+ -> IO ()+keyUpdate ctx getState setState = do+ (usedHash, usedCipher, level, applicationSecretN) <- getState ctx+ unless (level == CryptApplicationSecret) $+ throwCore $+ Error_Protocol+ "tried key update without application traffic secret"+ InternalError+ let applicationSecretN1 =+ hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $+ hashDigestSize usedHash+ setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1)++-- | How to update keys in TLS 1.3+data KeyUpdateRequest+ = -- | Unidirectional key update+ OneWay+ | -- | Bidirectional key update (normal case)+ TwoWay+ deriving (Eq, Show)++-- | Updating application traffic secrets for TLS 1.3.+-- If this API is called for TLS 1.3, 'True' is returned.+-- Otherwise, 'False' is returned.+updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool+updateKey ctx way = liftIO $ do+ tls13 <- tls13orLater ctx+ when tls13 $ do+ let req = case way of+ OneWay -> UpdateNotRequested+ TwoWay -> UpdateRequested+ -- Write lock wraps both actions because we don't want another packet to+ -- be sent by another thread before the Tx state is updated.+ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] []+ keyUpdate ctx getTxRecordState setTxRecordState+ return tls13
Network/TLS/Handshake/State.hs view
@@ -4,7 +4,7 @@ module Network.TLS.Handshake.State ( HandshakeState (..),- HandshakeDigest (..),+ TransHashState (..), HandshakeMode13 (..), RTT0Status (..), CertReqCBdata,@@ -27,6 +27,16 @@ getGroupPrivate, -- * cert accessors+ setClientRandom,+ getClientRandom,+ setOuterClientRandom,+ getOuterClientRandom,+ setClientHello,+ getClientHello,+ setECHEE,+ getECHEE,+ setECHAccepted,+ getECHAccepted, setClientCertSent, getClientCertSent, setCertReqSent,@@ -42,11 +52,7 @@ -- * digest accessors addHandshakeMessage,- updateHandshakeDigest, getHandshakeMessages,- getHandshakeMessagesRev,- getHandshakeDigest,- foldHandshakeDigest, -- * main secret setMainSecret,@@ -54,7 +60,6 @@ -- * misc accessor getPendingCipher,- setServerHelloParameters, setExtendedMainSecret, getExtendedMainSecret, setSupportedGroup,@@ -67,12 +72,16 @@ getTLS13EarlySecret, setTLS13ResumptionSecret, getTLS13ResumptionSecret,+ setTLS13CertComp,+ getTLS13CertComp, setCCS13Sent, getCCS13Sent,+ setCCS13Recv,+ getCCS13Recv, ) where import Control.Monad.State.Strict-import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray (convert) import Data.X509 (CertificateChain) import Network.TLS.Cipher@@ -91,23 +100,37 @@ } deriving (Show) -data HandshakeDigest- = HandshakeMessages [ByteString]- | HandshakeDigestContext HashCtx- deriving (Show)+data TransHashState+ = -- | Initial state+ TransHashState0+ | -- | A raw CH is stored since hash algo is not chosen yet.+ TransHashState1 [ByteString]+ | -- | Hashed+ TransHashState2 HashCtx +{- FOURMOLU_DISABLE -}+instance Show TransHashState where+ show TransHashState0 = "State0 "+ show (TransHashState1 _) = "State1 CH"+ show (TransHashState2 hctx) = showBytesHex $ hashFinal hctx+{- FOURMOLU_ENABLE -}+ data HandshakeState = HandshakeState { hstClientVersion :: Version , hstClientRandom :: ClientRandom+ -- ^ For ECH, inner client random. , hstServerRandom :: Maybe ServerRandom- , hstMainSecret :: Maybe ByteString+ , hstMainSecret :: Maybe Secret , hstKeyState :: HandshakeKeyState , hstServerDHParams :: Maybe ServerDHParams , hstDHPrivate :: Maybe DHPrivate , hstServerECDHParams :: Maybe ServerECDHParams- , hstGroupPrivate :: Maybe GroupPrivate- , hstHandshakeDigest :: HandshakeDigest+ , hstGroupPrivate :: [(Group, GroupPrivate)]+ , hstTransHashState :: TransHashState+ , hstTransHashStateI :: TransHashState -- Inner CH for client ECH , hstHandshakeMessages :: [ByteString]+ -- ^ To create certificate verify for TLS 1.2.+ -- This should be removed when TLS 1.2 is dropped. , hstCertReqToken :: Maybe ByteString -- ^ Set to Just-value when a TLS13 certificate request is received , hstCertReqCBdata :: Maybe CertReqCBdata@@ -131,9 +154,17 @@ , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status- , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret)+ , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret)+ , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool+ , hstCCS13Recv :: Bool+ , hstTLS13OuterClientRandom :: Maybe ClientRandom+ -- ^ Used for key logging in the case of ECH.+ , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString])+ -- ^ Inner client hello in the case of ECH.+ , hstTLS13ECHAccepted :: Bool+ , hstTLS13ECHEE :: Bool } deriving (Show) @@ -205,8 +236,9 @@ , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing- , hstGroupPrivate = Nothing- , hstHandshakeDigest = HandshakeMessages []+ , hstGroupPrivate = []+ , hstTransHashState = TransHashState0+ , hstTransHashStateI = TransHashState0 , hstHandshakeMessages = [] , hstCertReqToken = Nothing , hstCertReqCBdata = Nothing@@ -224,19 +256,25 @@ , hstTLS13RTT0Status = RTT0None , hstTLS13EarlySecret = Nothing , hstTLS13ResumptionSecret = Nothing+ , hstTLS13CertComp = False , hstCCS13Sent = False+ , hstCCS13Recv = False+ , hstTLS13OuterClientRandom = Nothing+ , hstTLS13ClientHello = Nothing+ , hstTLS13ECHAccepted = False+ , hstTLS13ECHEE = False } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState) runHandshake hst f = runState (runHandshakeM f) hst setPublicKey :: PubKey -> HandshakeM ()-setPublicKey pk = modify (\hst -> hst{hstKeyState = setPK (hstKeyState hst)})+setPublicKey pk = modify' (\hst -> hst{hstKeyState = setPK (hstKeyState hst)}) where setPK hks = hks{hksRemotePublicKey = Just pk} setPublicPrivateKeys :: (PubKey, PrivKey) -> HandshakeM ()-setPublicPrivateKeys keys = modify (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)})+setPublicPrivateKeys keys = modify' (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)}) where setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} @@ -248,37 +286,37 @@ fromJust <$> gets (hksLocalPublicPrivateKeys . hstKeyState) setServerDHParams :: ServerDHParams -> HandshakeM ()-setServerDHParams shp = modify (\hst -> hst{hstServerDHParams = Just shp})+setServerDHParams shp = modify' (\hst -> hst{hstServerDHParams = Just shp}) getServerDHParams :: HandshakeM ServerDHParams getServerDHParams = fromJust <$> gets hstServerDHParams setServerECDHParams :: ServerECDHParams -> HandshakeM ()-setServerECDHParams shp = modify (\hst -> hst{hstServerECDHParams = Just shp})+setServerECDHParams shp = modify' (\hst -> hst{hstServerECDHParams = Just shp}) getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust <$> gets hstServerECDHParams setDHPrivate :: DHPrivate -> HandshakeM ()-setDHPrivate shp = modify (\hst -> hst{hstDHPrivate = Just shp})+setDHPrivate shp = modify' (\hst -> hst{hstDHPrivate = Just shp}) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate-getGroupPrivate = fromJust <$> gets hstGroupPrivate+getGroupPrivate :: HandshakeM [(Group, GroupPrivate)]+getGroupPrivate = gets hstGroupPrivate -setGroupPrivate :: GroupPrivate -> HandshakeM ()-setGroupPrivate shp = modify (\hst -> hst{hstGroupPrivate = Just shp})+setGroupPrivate :: [(Group, GroupPrivate)] -> HandshakeM ()+setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = shp}) setExtendedMainSecret :: Bool -> HandshakeM ()-setExtendedMainSecret b = modify (\hst -> hst{hstExtendedMainSecret = b})+setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b}) getExtendedMainSecret :: HandshakeM Bool getExtendedMainSecret = gets hstExtendedMainSecret setSupportedGroup :: Group -> HandshakeM ()-setSupportedGroup g = modify (\hst -> hst{hstSupportedGroup = Just g})+setSupportedGroup g = modify' (\hst -> hst{hstSupportedGroup = Just g}) getSupportedGroup :: HandshakeM (Maybe Group) getSupportedGroup = gets hstSupportedGroup@@ -296,7 +334,7 @@ deriving (Show, Eq) setTLS13HandshakeMode :: HandshakeMode13 -> HandshakeM ()-setTLS13HandshakeMode s = modify (\hst -> hst{hstTLS13HandshakeMode = s})+setTLS13HandshakeMode s = modify' (\hst -> hst{hstTLS13HandshakeMode = s}) getTLS13HandshakeMode :: HandshakeM HandshakeMode13 getTLS13HandshakeMode = gets hstTLS13HandshakeMode@@ -309,64 +347,106 @@ deriving (Show, Eq) setTLS13RTT0Status :: RTT0Status -> HandshakeM ()-setTLS13RTT0Status s = modify (\hst -> hst{hstTLS13RTT0Status = s})+setTLS13RTT0Status s = modify' (\hst -> hst{hstTLS13RTT0Status = s}) getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM ()-setTLS13EarlySecret secret = modify (\hst -> hst{hstTLS13EarlySecret = Just secret})+setTLS13EarlySecret secret = modify' (\hst -> hst{hstTLS13EarlySecret = Just secret}) getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) getTLS13EarlySecret = gets hstTLS13EarlySecret setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM ()-setTLS13ResumptionSecret secret = modify (\hst -> hst{hstTLS13ResumptionSecret = Just secret})+setTLS13ResumptionSecret secret = modify' (\hst -> hst{hstTLS13ResumptionSecret = Just secret}) getTLS13ResumptionSecret :: HandshakeM (Maybe (BaseSecret ResumptionSecret)) getTLS13ResumptionSecret = gets hstTLS13ResumptionSecret +setTLS13CertComp :: Bool -> HandshakeM ()+setTLS13CertComp comp = modify' (\hst -> hst{hstTLS13CertComp = comp})++getTLS13CertComp :: HandshakeM Bool+getTLS13CertComp = gets hstTLS13CertComp+ setCCS13Sent :: Bool -> HandshakeM ()-setCCS13Sent sent = modify (\hst -> hst{hstCCS13Sent = sent})+setCCS13Sent sent = modify' (\hst -> hst{hstCCS13Sent = sent}) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent +setCCS13Recv :: Bool -> HandshakeM ()+setCCS13Recv sent = modify' (\hst -> hst{hstCCS13Recv = sent})++getCCS13Recv :: HandshakeM Bool+getCCS13Recv = gets hstCCS13Recv+ setCertReqSent :: Bool -> HandshakeM ()-setCertReqSent b = modify (\hst -> hst{hstCertReqSent = b})+setCertReqSent b = modify' (\hst -> hst{hstCertReqSent = b}) getCertReqSent :: HandshakeM Bool getCertReqSent = gets hstCertReqSent setClientCertSent :: Bool -> HandshakeM ()-setClientCertSent b = modify (\hst -> hst{hstClientCertSent = b})+setClientCertSent b = modify' (\hst -> hst{hstClientCertSent = b}) +getClientRandom :: HandshakeM ClientRandom+getClientRandom = gets hstClientRandom++setClientRandom :: ClientRandom -> HandshakeM ()+setClientRandom cr = modify' $ \hst -> hst{hstClientRandom = cr}++getOuterClientRandom :: HandshakeM (Maybe ClientRandom)+getOuterClientRandom = gets hstTLS13OuterClientRandom++setOuterClientRandom :: Maybe ClientRandom -> HandshakeM ()+setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr})++getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString]))+getClientHello = gets hstTLS13ClientHello++setClientHello :: ClientHello -> [ByteString] -> HandshakeM ()+setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)}++getECHAccepted :: HandshakeM Bool+getECHAccepted = gets hstTLS13ECHAccepted++setECHAccepted :: Bool -> HandshakeM ()+setECHAccepted b = modify' $ \hst -> hst{hstTLS13ECHAccepted = b}++getECHEE :: HandshakeM Bool+getECHEE = gets hstTLS13ECHEE++setECHEE :: Bool -> HandshakeM ()+setECHEE b = modify' $ \hst -> hst{hstTLS13ECHEE = b}+ getClientCertSent :: HandshakeM Bool getClientCertSent = gets hstClientCertSent setClientCertChain :: CertificateChain -> HandshakeM ()-setClientCertChain b = modify (\hst -> hst{hstClientCertChain = Just b})+setClientCertChain b = modify' (\hst -> hst{hstClientCertChain = Just b}) getClientCertChain :: HandshakeM (Maybe CertificateChain) getClientCertChain = gets hstClientCertChain -- setCertReqToken :: Maybe ByteString -> HandshakeM ()-setCertReqToken token = modify $ \hst -> hst{hstCertReqToken = token}+setCertReqToken token = modify' $ \hst -> hst{hstCertReqToken = token} getCertReqToken :: HandshakeM (Maybe ByteString) getCertReqToken = gets hstCertReqToken -- setCertReqCBdata :: Maybe CertReqCBdata -> HandshakeM ()-setCertReqCBdata d = modify (\hst -> hst{hstCertReqCBdata = d})+setCertReqCBdata d = modify' (\hst -> hst{hstCertReqCBdata = d}) getCertReqCBdata :: HandshakeM (Maybe CertReqCBdata) getCertReqCBdata = gets hstCertReqCBdata -- Dead code, until we find some use for the extension setCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] -> HandshakeM ()-setCertReqSigAlgsCert as = modify $ \hst -> hst{hstCertReqSigAlgsCert = as}+setCertReqSigAlgsCert as = modify' $ \hst -> hst{hstCertReqSigAlgsCert = as} getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert@@ -376,73 +456,20 @@ getPendingCipher = fromJust <$> gets hstPendingCipher addHandshakeMessage :: ByteString -> HandshakeM ()-addHandshakeMessage content = modify $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs}+addHandshakeMessage content = modify' $ \hs -> hs{hstHandshakeMessages = content : hstHandshakeMessages hs} getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) -getHandshakeMessagesRev :: HandshakeM [ByteString]-getHandshakeMessagesRev = gets hstHandshakeMessages--updateHandshakeDigest :: ByteString -> HandshakeM ()-updateHandshakeDigest content = modify $ \hs ->- hs- { hstHandshakeDigest = case hstHandshakeDigest hs of- HandshakeMessages bytes -> HandshakeMessages (content : bytes)- HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content- }---- | Compress the whole transcript with the specified function. Function @f@--- takes the handshake digest as input and returns an encoded handshake message--- to replace the transcript with.-foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM ()-foldHandshakeDigest hashAlg f = modify $ \hs ->- case hstHandshakeDigest hs of- HandshakeMessages bytes ->- let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes- folded = f (hashFinal hashCtx)- in hs- { hstHandshakeDigest = HandshakeMessages [folded]- , hstHandshakeMessages = [folded]- }- HandshakeDigestContext hashCtx ->- let folded = f (hashFinal hashCtx)- hashCtx' = hashUpdate (hashInit hashAlg) folded- in hs- { hstHandshakeDigest = HandshakeDigestContext hashCtx'- , hstHandshakeMessages = [folded]- }--getSessionHash :: HandshakeM ByteString-getSessionHash = gets $ \hst ->- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized session hash"--getHandshakeDigest :: Version -> Role -> HandshakeM ByteString-getHandshakeDigest ver role = gets gen- where- gen hst = case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx ->- let msecret = fromJust $ hstMainSecret hst- cipher = fromJust $ hstPendingCipher hst- in generateFinished ver cipher msecret hashCtx- HandshakeMessages _ ->- error "un-initialized handshake digest"- generateFinished- | role == ClientRole = generateClientFinished- | otherwise = generateServerFinished- -- | Generate the main secret from the pre-main secret. setMainSecretFromPre- :: ByteArrayAccess preMain- => Version+ :: Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side- -> preMain+ -> Secret -- ^ the pre-main secret- -> HandshakeM ByteString+ -> HandshakeM Secret setMainSecretFromPre ver role preMainSecret = do ems <- getExtendedMainSecret secret <- if ems then get >>= genExtendedSecret else genSecret <$> get@@ -463,10 +490,16 @@ preMainSecret <$> getSessionHash +getSessionHash :: HandshakeM ByteString+getSessionHash = gets $ \hst ->+ case hstTransHashState hst of+ TransHashState2 hashCtx -> hashFinal hashCtx+ _ -> error "un-initialized session hash"+ -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state.-setMainSecret :: Version -> Role -> ByteString -> HandshakeM ()-setMainSecret ver role mainSecret = modify $ \hst ->+setMainSecret :: Version -> Role -> Secret -> HandshakeM ()+setMainSecret ver role mainSecret = modify' $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role in hst { hstMainSecret = Just mainSecret@@ -475,7 +508,7 @@ } computeKeyBlock- :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState)+ :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust $ hstPendingCipher hst@@ -504,13 +537,13 @@ cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey- , cstIV = cWriteIV+ , cstIV = convert $ cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey- , cstIV = sWriteIV+ , cstIV = convert $ sWriteIV , cstMacSecret = sMACSecret } msClient = MacState{msSequence = 0}@@ -534,31 +567,3 @@ } orOnServer f g = if cc == ClientRole then f else g--setServerHelloParameters- :: Version- -- ^ chosen version- -> ServerRandom- -> Cipher- -> Compression- -> HandshakeM ()-setServerHelloParameters ver sran cipher compression = do- modify $ \hst ->- hst- { hstServerRandom = Just sran- , hstPendingCipher = Just cipher- , hstPendingCompression = compression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- where- hashAlg = getHash ver cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- The TLS12 Hash is cipher specific, and some TLS12 algorithms use SHA384--- instead of the default SHA256.-getHash :: Version -> Cipher -> Hash-getHash ver ciph- | ver < TLS12 = SHA1_MD5- | maybe True (< TLS12) (cipherMinVer ciph) = SHA256- | otherwise = cipherHash ciph
Network/TLS/Handshake/State13.hs view
@@ -15,40 +15,32 @@ getRxLevel, clearTxRecordState, clearRxRecordState,- setHelloParameters13,- transcriptHash,- wrapAsMessageHash13, PendingRecvAction (..), setPendingRecvActions, popPendingRecvAction, ) where import Control.Concurrent.MVar-import Control.Monad.State-import qualified Data.ByteString as B import Data.IORef import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal-import Network.TLS.Crypto-import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel) import Network.TLS.Record.State-import Network.TLS.Struct import Network.TLS.Types -getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getRxRecordState ctx = getXState ctx ctxRxRecordState getXState :: Context -> (Context -> MVar RecordState)- -> IO (Hash, Cipher, CryptLevel, ByteString)+ -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do tx <- readMVar (func ctx) let usedCipher = fromJust $ stCipher tx@@ -74,7 +66,7 @@ return $ stCryptLevel tx class TrafficSecret ty where- fromTrafficSecret :: ty -> (CryptLevel, ByteString)+ fromTrafficSecret :: ty -> (CryptLevel, Secret) instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s)@@ -111,7 +103,7 @@ -> Hash -> Cipher -> CryptLevel- -> ByteString+ -> Secret -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt)@@ -145,51 +137,6 @@ clearXState :: (Context -> MVar RecordState) -> Context -> IO () clearXState func ctx = modifyMVar_ (func ctx) (\rt -> return rt{stCipher = Nothing})--setHelloParameters13 :: Cipher -> HandshakeM (Either TLSError ())-setHelloParameters13 cipher = do- hst <- get- case hstPendingCipher hst of- Nothing -> do- put- hst- { hstPendingCipher = Just cipher- , hstPendingCompression = nullCompression- , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst- }- return $ Right ()- Just oldcipher- | cipher == oldcipher -> return $ Right ()- | otherwise ->- return $- Left $- Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter- where- hashAlg = cipherHash cipher- updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"---- When a HelloRetryRequest is sent or received, the existing transcript must be--- wrapped in a "message_hash" construct. See RFC 8446 section 4.4.1. This--- applies to key-schedule computations as well as the ones for PSK binders.-wrapAsMessageHash13 :: HandshakeM ()-wrapAsMessageHash13 = do- cipher <- getPendingCipher- foldHandshakeDigest (cipherHash cipher) foldFunc- where- foldFunc dig =- B.concat- [ "\254\0\0"- , B.singleton (fromIntegral $ B.length dig)- , dig- ]--transcriptHash :: MonadIO m => Context -> m ByteString-transcriptHash ctx = do- hst <- fromJust <$> getHState ctx- case hstHandshakeDigest hst of- HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx- HandshakeMessages _ -> error "un-initialized handshake digest" setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx)
+ Network/TLS/Handshake/TranscriptHash.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.TLS.Handshake.TranscriptHash (+ transcriptHash,+ transcriptHashWith,+ transitTranscriptHashI,+ updateTranscriptHash,+ updateTranscriptHashI,+ transitTranscriptHash,+ copyTranscriptHash,+ TranscriptHash (..),+) where++import Control.Monad.State+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Parameters+import Network.TLS.State+import Network.TLS.Types++----------------------------------------------------------------++transitTranscriptHash :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHash ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = transit label hashAlg isHRR $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++transitTranscriptHashI :: Context -> String -> Hash -> Bool -> IO ()+transitTranscriptHashI ctx label hashAlg isHRR = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = transit label hashAlg isHRR $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++transit :: String -> Hash -> Bool -> TransHashState -> TransHashState+transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0+transit _ _ _ st2@(TransHashState2 _) = st2+transit _ hashAlg isHRR (TransHashState1 chs)+ | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg+ | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch+ where+ ch = reverse chs+ hsMsg =+ -- Handshake message:+ -- typ <-len-> body+ -- 254 0 0 len hash(CH1)+ B.concat+ [ "\254\0\0"+ , B.singleton len+ , hashedCH+ ]+ where+ hashedCH = hashChunks hashAlg ch+ len = fromIntegral $ B.length hashedCH++----------------------------------------------------------------++updateTranscriptHash :: Context -> String -> ByteString -> IO ()+updateTranscriptHash ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashState = update eh label $ hstTransHashState hst}+ traceTranscriptHash ctx label hstTransHashState++updateTranscriptHashI :: Context -> String -> ByteString -> IO ()+updateTranscriptHashI ctx label eh = do+ usingHState ctx $ modify' $ \hst ->+ hst{hstTransHashStateI = update eh label $ hstTransHashStateI hst}+ traceTranscriptHash ctx label hstTransHashStateI++update :: ByteString -> String -> TransHashState -> TransHashState+update eh _ TransHashState0 = TransHashState1 [eh]+update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss)+update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh++----------------------------------------------------------------++transcriptHash :: MonadIO m => Context -> String -> m TranscriptHash+transcriptHash ctx label = do+ hst <- fromJust <$> getHState ctx+ let th = calc label $ hstTransHashState hst+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calc :: String -> TransHashState -> ByteString+calc _ (TransHashState2 hashCtx) = hashFinal hashCtx+calc label st = error $ "transcriptHash " ++ label ++ " " ++ show st++----------------------------------------------------------------++transcriptHashWith+ :: MonadIO m => Context -> String -> ByteString -> m TranscriptHash+transcriptHashWith ctx label bs = do+ role <- liftIO $ usingState_ ctx getRole+ let isClient = role == ClientRole+ hst <- fromJust <$> getHState ctx+ let st+ | isClient = hstTransHashStateI hst+ | otherwise = hstTransHashState hst+ let th = calcWith bs label st+ liftIO $ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ showBytesHex th+ return $ TranscriptHash th++calcWith :: ByteString -> String -> TransHashState -> ByteString+calcWith bs _ (TransHashState2 hashCtx) = hashFinal $ hashUpdate hashCtx bs+calcWith _ label st = error $ "transcriptHashWith " ++ label ++ " " ++ show st++----------------------------------------------------------------++copyTranscriptHash :: Context -> String -> IO ()+copyTranscriptHash ctx label = do+ usingHState ctx $ modify' $ \hst ->+ hst+ { hstTransHashState = hstTransHashStateI hst+ }+ traceTranscriptHash ctx label hstTransHashState++----------------------------------------------------------------++traceTranscriptHash+ :: Context -> String -> (HandshakeState -> TransHashState) -> IO ()+traceTranscriptHash ctx label getField = do+ hst <- fromJust <$> getHState ctx+ debugTraceKey (ctxDebug ctx) $ adjustLabel label ++ show (getField hst)++adjustLabel :: String -> String+adjustLabel label = take 24 (label ++ " ")
+ Network/TLS/HashAndSignature.hs view
@@ -0,0 +1,181 @@+{-# 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,+ SignatureBrainpoolP256,+ SignatureBrainpoolP384,+ SignatureBrainpoolP512+ ),+ HashAndSignatureAlgorithm,+ supportedSignatureSchemes,+ signatureSchemesForTLS13,+) 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+pattern SignatureBrainpoolP256 :: SignatureAlgorithm -- RFC8734+pattern SignatureBrainpoolP256 = SignatureAlgorithm 26+pattern SignatureBrainpoolP384 :: SignatureAlgorithm+pattern SignatureBrainpoolP384 = SignatureAlgorithm 27+pattern SignatureBrainpoolP512 :: SignatureAlgorithm+pattern SignatureBrainpoolP512 = SignatureAlgorithm 28++instance Show SignatureAlgorithm where+ show SignatureAnonymous = "Anonymous"+ 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 SignatureBrainpoolP256 = "BrainpoolP256"+ show SignatureBrainpoolP384 = "BrainpoolP384"+ show SignatureBrainpoolP512 = "BrainpoolP512"+ 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+ , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603)+ , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503)+ , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)+ -- RSASSA-PSS RSAE algorithms+ , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)+ , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)+ , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)+ -- RSASSA-PSS PSS algorithms with+ , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b)+ , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a)+ , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809)+ -- 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)+ ]++signatureSchemesForTLS13 :: [(HashAlgorithm, SignatureAlgorithm)]+signatureSchemesForTLS13 =+ -- EdDSA algorithms+ [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808)+ , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807)+ -- ECDSA algorithms+ , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603)+ , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503)+ , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403)+ -- RSASSA-PSS RSAE algorithms+ , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)+ , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)+ , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)+ -- RSASSA-PSS PSS algorithms with+ , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b)+ , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a)+ , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809)+ ]+{- FOURMOLU_ENABLE -}
Network/TLS/Hooks.hs view
@@ -1,11 +1,13 @@ module Network.TLS.Hooks ( Logging (..),+ defaultLogging, Hooks (..), defaultHooks, ) where -import qualified Data.ByteString as B-import Data.Default.Class+import Data.Default (Default (def))++import Network.TLS.Imports import Network.TLS.Struct (Handshake, Header) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain)@@ -16,8 +18,8 @@ data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO ()- , loggingIOSent :: B.ByteString -> IO ()- , loggingIORecv :: Header -> B.ByteString -> IO ()+ , loggingIOSent :: ByteString -> IO ()+ , loggingIORecv :: Header -> ByteString -> IO () } defaultLogging :: Logging
Network/TLS/IO.hs view
@@ -24,10 +24,11 @@ import Network.TLS.Context.Internal import Network.TLS.Hooks+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Receiving+import Network.TLS.Parameters import Network.TLS.Record-import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13@@ -37,9 +38,10 @@ -- | Send one packet to the context sendPacket12 :: Context -> Packet -> IO () sendPacket12 ctx@Context{ctxRecordLayer = recordLayer} pkt = do- -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is sent before a normal data packet, to- -- prevent guessability.+ -- in ver <= TLS1.0, block ciphers using CBC are using CBC residue+ -- as IV, which can be guessed by an attacker. Hence, an empty+ -- packet is sent before a normal data packet, to prevent+ -- guessability. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $@@ -85,89 +87,118 @@ -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket12 :: Context -> IO (Either TLSError Packet)-recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = do- hrr <- usingState_ ctx getTLS13HRR- -- When a client sends 0-RTT data to a server which rejects and sends a HRR,- -- the server will not decrypt AppData segments. The server needs to accept- -- AppData with maximum size 2^14 + 256. In all other scenarios and record- -- types the maximum size is 2^14.- let appDataOverhead = if hrr then 256 else 0- erecord <- recordRecv recordLayer ctx appDataOverhead- case erecord of- Left err -> return $ Left err- Right record ->- if hrr && isCCS record- then recvPacket12 ctx- else do- pktRecv <- processPacket ctx record+recvPacket12 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx+ loop count+ | count > lim = do+ let err = Error_Packet "too many handshake fragment"+ logPacket ctx $ show err+ return $ Left err+ loop count = do+ hrr <- usingState_ ctx getTLS13HRR+ erecord <- recordRecv12 recordLayer ctx+ case erecord of+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ Right record+ | hrr && isCCS record -> loop (count + 1)+ | otherwise -> do+ pktRecv <- decodePacket12 ctx record if isEmptyHandshake pktRecv- then -- When a handshake record is fragmented we continue- -- receiving in order to feed stHandshakeRecordCont- recvPacket12 ctx- else do- pkt <- case pktRecv of- Right (Handshake hss) ->- ctxWithHooks ctx $ \hooks ->- Right . Handshake <$> mapM (hookRecvHandshake hooks) hss- _ -> return pktRecv- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- return pkt+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented+ -- we continue receiving in order to feed+ -- stHandshakeRecordCont+ loop (count + 1)+ else case pktRecv of+ Right (Handshake hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake hooks) hss+ return $ Right $ Handshake hss' bss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool-isEmptyHandshake (Right (Handshake [])) = True+isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False +logPacket :: Context -> String -> IO ()+logPacket ctx msg = withLog ctx $ \logging -> loggingPacketRecv logging msg+ ---------------------------------------------------------------- recvPacket13 :: Context -> IO (Either TLSError Packet13)-recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do- erecord <- recordRecv13 recordLayer ctx- case erecord of- Left err@(Error_Protocol _ BadRecordMac) -> do- -- If the server decides to reject RTT0 data but accepts RTT1- -- data, the server should skip all records for RTT0 data.- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacket13 ctx- _ -> return $ Left err- Left err -> return $ Left err- Right record -> do- pktRecv <- processPacket13 ctx record- if isEmptyHandshake13 pktRecv- then -- When a handshake record is fragmented we continue receiving- -- in order to feed stHandshakeRecordCont13- recvPacket13 ctx- else do- pkt <- case pktRecv of- Right (Handshake13 hss) ->- ctxWithHooks ctx $ \hooks ->- Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss- _ -> return pktRecv- case pkt of- Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p- _ -> return ()- return pkt+recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = loop 0+ where+ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx+ loop count+ | count > lim =+ return $ Left $ Error_Packet "too many handshake fragment"+ loop count = do+ erecord <- recordRecv13 recordLayer ctx+ case erecord of+ Left err@(Error_Protocol _ BadRecordMac) -> do+ -- If the server decides to reject RTT0 data but accepts RTT1+ -- data, the server should skip all records for RTT0 data.+ logPacket ctx $ show err+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed n+ | n > 0 -> do+ setEstablished ctx $ EarlyDataNotAllowed (n - 1)+ loop (count + 1)+ _ -> return $ Left err+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ Right record -> do+ pktRecv <- decodePacket13 ctx record+ if isEmptyHandshake13 pktRecv+ then do+ logPacket ctx "Handshake fragment"+ -- When a handshake record is fragmented we+ -- continue receiving in order to feed+ -- stHandshakeRecordCont13+ loop (count + 1)+ else do+ case pktRecv of+ Right (Handshake13 hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake13 hooks) hss+ return $ Right $ Handshake13 hss' bss+ logPacket ctx $ show pkt+ return pktRecv'+ Right pkt -> do+ logPacket ctx $ show pkt+ return pktRecv+ Left err -> do+ logPacket ctx $ show err+ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool-isEmptyHandshake13 (Right (Handshake13 [])) = True+isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False ---------------------------------------------------------------- isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do- cont <- gets stHandshakeRecordCont+ cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13- return $ isNothing cont && isNothing cont13+ return $ isNothing (fst cont12) && isNothing (fst cont13) checkValid :: Context -> IO () checkValid ctx = do@@ -206,4 +237,4 @@ (recordLayer, ref) <- ask liftIO $ do bs <- writePacketBytes13 ctx recordLayer pkt- modifyIORef ref (. (bs :))+ modifyIORef' ref (. (bs :))
+ Network/TLS/IO/Decode.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.IO.Decode (+ decodePacket12,+ decodePacket13,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as BS++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.ErrT+import Network.TLS.Handshake.State+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Util+import Network.TLS.Wire++decodePacket12 :: Context -> Record Plaintext -> IO (Either TLSError Packet)+decodePacket12 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment+decodePacket12 _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment))+decodePacket12 ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left err -> return $ Left err+ Right _ -> do+ switchRxEncryption ctx+ return $ Right ChangeCipherSpec+decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do+ keyxchg <-+ getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)+ usingState ctx $ do+ let currentParams =+ CurrentParams+ { cParamsVersion = ver+ , cParamsKeyXchgType = keyxchg+ }+ -- get back the optional continuation, and parse as many handshake record as possible.+ (mCont, wirebytes) <- gets stHandshakeRecordCont12+ modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])})+ (hss, bss) <-+ unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake hss bss+ where+ parseMany currentParams mCont wirebytes bs =+ case fromMaybe decodeHandshakeRecord mCont bs of+ GotError err -> throwError err+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)})+ return []+ GotSuccess (ty, content) ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))]+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right h -> do+ hbs <- parseMany currentParams Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")++switchRxEncryption :: Context -> IO ()+switchRxEncryption ctx =+ usingHState ctx (gets hstPendingRxState) >>= \rx ->+ modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)++----------------------------------------------------------------++decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)+decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left err -> return $ Left err+ Right _ -> return $ Right ChangeCipherSpec13+decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment+decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))+decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do+ (mCont, wirebytes) <- gets stHandshakeRecordCont13+ modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})+ (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake13 hss bss+ where+ parseMany mCont wirebytes bs =+ case fromMaybe decodeHandshakeRecord13 mCont bs of+ GotError err -> throwError err+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)})+ return []+ GotSuccess (ty, content) ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))]+ GotSuccessRemaining (ty, content) left ->+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right h -> do+ hbs <- parseMany Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
+ Network/TLS/IO/Encode.hs view
@@ -0,0 +1,148 @@+module Network.TLS.IO.Encode (+ encodePacket12,+ encodePacket13,+ updateTranscriptHash12,+ encodeUpdateTranscriptHash12,+ updateTranscriptHash13,+ encodeUpdateTranscriptHash13,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B+import Data.IORef++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Handshake.State+import Network.TLS.Handshake.TranscriptHash+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Parameters+import Network.TLS.Record+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types (Role (..))+import Network.TLS.Util++-- | encodePacket transform a packet into marshalled data related to current state+-- and updating state on the go+encodePacket12+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet+ -> IO (Either TLSError bytes)+encodePacket12 ctx recordLayer pkt = do+ (ver, _) <- decideRecordVersion ctx+ let pt = packetType pkt+ mkRecord bs = Record pt ver (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments12 ctx mlen pkt+ bs <- fmap mconcat <$> forEitherM records (recordEncode12 recordLayer ctx)+ when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx+ return bs++-- Decompose handshake packets into fragments of the specified length. AppData+-- packets are not fragmented here but by callers of sendPacket, so that the+-- empty-packet countermeasure may be applied to each fragment independently.+packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]+packetToFragments12 ctx mlen (Handshake hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss+packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]+packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]+packetToFragments12 _ _ (AppData x) = return [x]++switchTxEncryption :: Context -> IO ()+switchTxEncryption ctx = do+ tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)+ (ver, role) <- usingState_ ctx $ do+ v <- getVersion+ r <- getRole+ return (v, r)+ liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)+ -- set empty packet counter measure if condition are met+ when+ ( ver <= TLS10+ && role == ClientRole+ && isCBC tx+ && supportedEmptyPacket (ctxSupported ctx)+ )+ $ liftIO+ $ writeIORef (ctxNeedEmptyPacket ctx) True+ where+ isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)++encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString+encodeUpdateTranscriptHash12 ctx hs = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ addHandshakeMessage encoded+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded+ when (isClientHello hs) $ do+ usingHState ctx $ do+ (ch, b) <- fromJust <$> getClientHello+ when (null b) $ setClientHello ch [encoded]+ return encoded+ where+ encoded = encodeHandshake hs+ isClientHello (ClientHello _) = True+ isClientHello _ = False++updateTranscriptHash12 :: Context -> HandshakeR -> IO ()+updateTranscriptHash12 ctx (hs, bss) = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ mapM_ addHandshakeMessage bss+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ do+ mapM_ (updateTranscriptHash ctx label) bss++----------------------------------------------------------------++encodePacket13+ :: Monoid bytes+ => Context+ -> RecordLayer bytes+ -> Packet13+ -> IO (Either TLSError bytes)+encodePacket13 ctx recordLayer pkt = do+ let pt = contentType pkt+ mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)+ mlen <- getPeerRecordLimit ctx+ records <- map mkRecord <$> packetToFragments13 ctx mlen pkt+ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)++packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]+packetToFragments13 ctx mlen (Handshake13 hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss+packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]+packetToFragments13 _ _ (AppData13 x) = return [x]+packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]++encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString+encodeUpdateTranscriptHash13 ctx hs+ | isIgnored hs = return encoded+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ updateTranscriptHash ctx label encoded+ usingHState ctx $ addHandshakeMessage encoded+ return encoded+ where+ encoded = encodeHandshake13 hs++updateTranscriptHash13 :: Context -> Handshake13R -> IO ()+updateTranscriptHash13 ctx (hs, bss)+ | isIgnored hs = return ()+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ mapM_ (updateTranscriptHash ctx label) bss+ usingHState ctx $ mapM_ addHandshakeMessage bss++isIgnored :: Handshake13 -> Bool+isIgnored NewSessionTicket13{} = True+isIgnored KeyUpdate13{} = True+isIgnored _ = False
Network/TLS/Imports.hs view
@@ -16,22 +16,18 @@ showBytesHex, ) where -import Data.ByteString (ByteString)-import Data.ByteString.Char8 ()---- instance-import Data.Functor- import Control.Applicative import Control.Monad import Data.Bits+import Data.ByteArray.Encoding as B+import Data.ByteString (ByteString)+import Data.ByteString.Char8 ()+import Data.Functor import Data.List import Data.Maybe import Data.Ord import Data.Semigroup import Data.Word--import Data.ByteArray.Encoding as B import qualified Prelude as P showBytesHex :: ByteString -> P.String
Network/TLS/Internal.hs view
@@ -1,24 +1,37 @@ {-# OPTIONS_HADDOCK hide #-} module Network.TLS.Internal (- module Network.TLS.Struct,- module Network.TLS.Struct13,+ module Network.TLS.Extension,+ module Network.TLS.IO.Decode,+ module Network.TLS.IO.Encode, module Network.TLS.Packet, module Network.TLS.Packet13,- module Network.TLS.Receiving,- module Network.TLS.Sending,+ module Network.TLS.Struct,+ module Network.TLS.Struct13, module Network.TLS.Types, module Network.TLS.Wire,+ module Network.TLS.X509, sendPacket12, recvPacket12,+ makeCipherShowPretty, ) where +import Data.IORef+ import Network.TLS.Core (recvPacket12, sendPacket12)+import Network.TLS.Extension+import Network.TLS.Extra.Cipher+import Network.TLS.IO.Decode+import Network.TLS.IO.Encode import Network.TLS.Packet import Network.TLS.Packet13-import Network.TLS.Receiving-import Network.TLS.Sending import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Wire+import Network.TLS.X509 hiding (Certificate)++----------------------------------------------------------------++makeCipherShowPretty :: IO ()+makeCipherShowPretty = writeIORef globalCipherDict ciphersuite_all
Network/TLS/KeySchedule.hs view
@@ -8,17 +8,20 @@ import qualified Crypto.Hash as H import Crypto.KDF.HKDF-import Data.ByteArray (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS+ import Network.TLS.Crypto import Network.TLS.Imports+import Network.TLS.Types import Network.TLS.Wire ---------------------------------------------------------------- -- | @HKDF-Extract@ function. Returns the pseudorandom key (PRK) from salt and -- input keying material (IKM).-hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString+hkdfExtract+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba -> ba hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256) hkdfExtract SHA384 salt ikm = convert (extract salt ikm :: PRK H.SHA384)@@ -27,8 +30,8 @@ ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString-deriveSecret h secret label hashedMsgs =+deriveSecret :: Hash -> Secret -> ByteString -> TranscriptHash -> Secret+deriveSecret h secret label (TranscriptHash hashedMsgs) = hkdfExpandLabel h secret label hashedMsgs outlen where outlen = hashDigestSize h@@ -38,12 +41,13 @@ -- | @HKDF-Expand-Label@ function. Returns output keying material of the -- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel- :: Hash- -> ByteString+ :: (ByteArray ba, ByteArrayAccess ba)+ => Hash+ -> Secret -> ByteString -> ByteString -> Int- -> ByteString+ -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do@@ -51,7 +55,8 @@ putOpaque8 ("tls13 " `BS.append` label) putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString+expand'+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> Secret -> ByteString -> Int -> ba expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len expand' SHA256 secret label len = expand (extractSkip secret :: PRK H.SHA256) label len expand' SHA384 secret label len = expand (extractSkip secret :: PRK H.SHA384) label len
Network/TLS/MAC.hs view
@@ -6,23 +6,25 @@ prf_SHA256, prf_TLS, prf_MD5SHA1,+ PRF, ) where -import qualified Data.ByteArray as B (xor)-import qualified Data.ByteString as B+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as BA+ import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString+type HMAC = Secret -> ByteString -> Secret macSSL :: Hash -> HMAC macSSL alg secret msg = f $- B.concat+ BA.concat [ secret- , B.replicate padLen 0x5c- , f $ B.concat [secret, B.replicate padLen 0x36, msg]+ , BA.replicate padLen 0x5c+ , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg] ] where padLen = case alg of@@ -31,49 +33,51 @@ _ -> error ("internal error: macSSL called with " ++ show alg) f = hash alg -hmac :: Hash -> HMAC-hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg)+hmac :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ByteString -> ba+hmac alg secret msg = f $ BA.append opad (f $ BA.append ipad $ BA.convert msg) where- opad = B.map (xor 0x5c) k'- ipad = B.map (xor 0x36) k'+ opad = BA.map (0x5c `xor`) k'+ ipad = BA.map (0x36 `xor`) k' f = hash alg bl = hashBlockSize alg - k' = B.append kt pad+ k' = BA.append kt pad where- kt = if B.length secret > fromIntegral bl then f secret else secret- pad = B.replicate (fromIntegral bl - B.length kt) 0+ kt = if BA.length secret > fromIntegral bl then f secret else secret+ pad = BA.replicate (fromIntegral bl - BA.length kt) 0 hmacIter- :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+ :: HMAC -> Secret -> ByteString -> ByteString -> Int -> [Secret] hmacIter f secret seed aprev len = let an = f secret aprev- in let out = f secret (B.concat [an, seed])- in let digestsize = B.length out+ in let out = f secret (BA.concat [an, BA.convert seed])+ in let digestsize = BA.length out in if digestsize >= len- then [B.take (fromIntegral len) out]- else out : hmacIter f secret seed an (len - digestsize)+ then [BA.take (fromIntegral len) out]+ else out : hmacIter f secret seed (BA.convert an) (len - digestsize) -prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len+type PRF = Secret -> ByteString -> Int -> Secret -prf_MD5 :: ByteString -> ByteString -> Int -> ByteString-prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len+prf_SHA1 :: PRF+prf_SHA1 secret seed len = BA.concat $ hmacIter (hmac SHA1) secret seed seed len -prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5 :: PRF+prf_MD5 secret seed len = BA.concat $ hmacIter (hmac MD5) secret seed seed len++prf_MD5SHA1 :: PRF prf_MD5SHA1 secret seed len =- B.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) where- slen = B.length secret- s1 = B.take (slen `div` 2 + slen `mod` 2) secret- s2 = B.drop (slen `div` 2) secret+ slen = BA.length secret+ s1 = BA.take (slen `div` 2 + slen `mod` 2) secret+ s2 = BA.drop (slen `div` 2) secret -prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA256 secret seed len = B.concat $ hmacIter (hmac SHA256) secret seed seed len+prf_SHA256 :: PRF+prf_SHA256 secret seed len = BA.concat $ hmacIter (hmac SHA256) secret seed seed len -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version.-prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString+prf_TLS :: Version -> Hash -> PRF prf_TLS _ halg secret seed len =- B.concat $ hmacIter (hmac halg) secret seed seed len+ BA.concat $ hmacIter (hmac halg) secret seed seed len
Network/TLS/Packet.hs view
@@ -21,7 +21,9 @@ decodeHandshakeRecord, decodeHandshake, encodeHandshake,+ encodeHandshake', encodeCertificate,+ decodeClientHello', -- * marshall functions for change cipher spec message decodeChangeCipherSpec,@@ -36,8 +38,6 @@ generateMainSecret, generateExtendedMainSecret, generateKeyBlock,- generateClientFinished,- generateServerFinished, -- * for extensions parsing getSignatureHashAlgorithm,@@ -55,10 +55,13 @@ putDNames, getDNames, getHandshakeType,++ -- * PRF+ PRF,+ getPRF, ) where -import Data.ByteArray (ByteArrayAccess)-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArrayAccess, convert) import qualified Data.ByteString as B import Data.X509 ( CertificateChain,@@ -66,14 +69,18 @@ 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 +----------------------------------------------------------------+-- Header+ data CurrentParams = CurrentParams { cParamsVersion :: Version -- ^ current protocol version@@ -82,7 +89,7 @@ } deriving (Show, Eq) -{- marshall helpers -}+-- marshall helpers getBinaryVersion :: Get Version getBinaryVersion = Version <$> getWord16 @@ -98,9 +105,7 @@ getHandshakeType :: Get HandshakeType getHandshakeType = HandshakeType <$> getWord8 -{-- - decode and encode headers- -}+-- decode and encode headers decodeHeader :: ByteString -> Either TLSError Header decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getBinaryVersion <*> getWord16@@ -108,11 +113,24 @@ encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) -{- FIXME check len <= 2^14 -}+-- FIXME check len <= 2^14 -{-- - decode and encode ALERT- -}+------------------------------------------------------------+-- CCS++decodeChangeCipherSpec :: ByteString -> Either TLSError ()+decodeChangeCipherSpec = runGetErr "changecipherspec" $ do+ x <- getWord8+ when (x /= 1) $ fail "unknown change cipher spec content"+ len <- remaining+ when (len /= 0) $ fail "the length of CSS must be 1"++encodeChangeCipherSpec :: ByteString+encodeChangeCipherSpec = runPut (putWord8 1)++----------------------------------------------------------------+-- Alert+ decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do al <- AlertLevel <$> getWord8@@ -133,66 +151,98 @@ where encodeAlert (al, ad) = putWord8 (fromAlertLevel al) >> putWord8 (fromAlertDescription ad) -{- decode and encode HANDSHAKE -}+----------------------------------------------------------------+-- decode HANDSHAKE+ decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType 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 False+ HandshakeType_ServerHello -> decodeServerHello HandshakeType_NewSessionTicket -> decodeNewSessionTicket+ 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 x -> fail $ "Unsupported HandshakeType " ++ show x+{- FOURMOLU_ENABLE -} decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest -decodeClientHello :: Get Handshake-decodeClientHello = do+decodeClientHello' :: ByteString -> Either TLSError Handshake+decodeClientHello' = runGetErr "decodeClientHello'" $ decodeClientHello True++decodeClientHello :: Bool -> Get Handshake+decodeClientHello inner = do 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 []- let ch = CH session ciphers exts- return $ ClientHello ver random compressions ch+ then getWord16 >>= getExtensions . fromIntegral+ else return []+ r1 <- remaining+ if inner+ then+ checkAndSkip r1+ else when (r1 /= 0) $ fail "Client hello has garbage"+ return $+ ClientHello $+ CH+ { chVersion = ver+ , chRandom = random+ , chSession = session+ , chCiphers = ciphers+ , chComps = compressions+ , chExtensions = exts+ }+ where+ checkAndSkip 0 = return ()+ checkAndSkip r = do+ zero <- getWord8+ when (zero /= 0) $ fail "Inner client hello has garbage"+ checkAndSkip (r - 1) decodeServerHello :: Get Handshake decodeServerHello = do ver <- getBinaryVersion random <- getServerRandom32 session <- getSession- cipherid <- getWord16+ cipherid <- CipherId <$> getWord16 compressionid <- getWord8 r <- remaining exts <- if r > 0- then fromIntegral <$> getWord16 >>= getExtensions+ then getWord16 >>= getExtensions . fromIntegral else return []- return $ ServerHello ver random session cipherid compressionid exts+ return $+ ServerHello $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = compressionid+ , shExtensions = exts+ } -decodeServerHelloDone :: Get Handshake-decodeServerHelloDone = return ServerHelloDone+decodeNewSessionTicket :: Get Handshake+decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16 decodeCertificate :: Get Handshake decodeCertificate = do@@ -201,71 +251,17 @@ <$> (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 $ CertificateChain_ cc where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) -decodeFinished :: Get Handshake-decodeFinished = Finished <$> (remaining >>= getBytes)--decodeNewSessionTicket :: Get Handshake-decodeNewSessionTicket = NewSessionTicket <$> getWord32 <*> getOpaque16--decodeCertRequest :: CurrentParams -> Get Handshake-decodeCertRequest _cp = do- certTypes <- map CertificateType <$> getWords8- sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms- CertRequest certTypes sigHashAlgs <$> getDNames- where- getSignatureHashAlgorithms len =- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))---- | Decode a list CA distinguished names-getDNames :: Get [DistinguishedName]-getDNames = do- dNameLen <- getWord16- -- FIXME: Decide whether to remove this check completely or to make it an option.- -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"- getList (fromIntegral dNameLen) getDName- where- getDName = do- dName <- getOpaque16- when (B.length dName == 0) $ fail "certrequest: invalid DN length"- dn <-- either fail return $ decodeASN1Object "cert request DistinguishedName" dName- return (2 + B.length dName, dn)--decodeCertVerify :: CurrentParams -> Get Handshake-decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)+---- -decodeClientKeyXchg :: CurrentParams -> Get Handshake-decodeClientKeyXchg cp =- -- case ClientKeyXchg <$> (remaining >>= getBytes)+decodeServerKeyXchg :: CurrentParams -> Get Handshake+decodeServerKeyXchg cp = case cParamsKeyXchgType cp of- Nothing -> error "no client key exchange type"- Just cke -> ClientKeyXchg <$> parseCKE cke- where- parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)- parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic- parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic- parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic- parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic- parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic- parseCKE _ = error "unsupported client key exchange type"- parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16- parseClientECDHPublic = CKX_ECDH <$> getOpaque8--decodeServerKeyXchg_DH :: Get ServerDHParams-decodeServerKeyXchg_DH = getServerDHParams---- We don't support ECDH_Anon at this moment--- decodeServerKeyXchg_ECDH :: Get ServerECDHParams--decodeServerKeyXchg_RSA :: Get ServerRSAParams-decodeServerKeyXchg_RSA =- ServerRSAParams- <$> getInteger16 -- modulus- <*> getInteger16 -- exponent+ Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke+ Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) decodeServerKeyXchgAlgorithmData :: Version@@ -296,12 +292,60 @@ bs <- remaining >>= getBytes return $ SKX_Unknown bs -decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp =+decodeServerKeyXchg_DH :: Get ServerDHParams+decodeServerKeyXchg_DH = getServerDHParams++-- We don't support ECDH_Anon at this moment+-- decodeServerKeyXchg_ECDH :: Get ServerECDHParams++decodeServerKeyXchg_RSA :: Get ServerRSAParams+decodeServerKeyXchg_RSA =+ ServerRSAParams+ <$> getInteger16 -- modulus+ <*> getInteger16 -- exponent++----++decodeCertRequest :: CurrentParams -> Get Handshake+decodeCertRequest _cp = do+ certTypes <- map CertificateType <$> getWords8+ sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms+ CertRequest certTypes sigHashAlgs <$> getDNames+ where+ getSignatureHashAlgorithms len =+ getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++----++decodeServerHelloDone :: Get Handshake+decodeServerHelloDone = return ServerHelloDone++decodeCertVerify :: CurrentParams -> Get Handshake+decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)++decodeClientKeyXchg :: CurrentParams -> Get Handshake+decodeClientKeyXchg cp =+ -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of- Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke- Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes)+ Nothing -> fail "no client key exchange type"+ Just cke -> ClientKeyXchg <$> parseCKE cke+ where+ parseCKE CipherKeyExchange_RSA = CKX_RSA <$> (remaining >>= getBytes)+ parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DHE_DSA = parseClientDHPublic+ parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic+ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic+ parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic+ parseCKE _ = fail "unsupported client key exchange type"+ parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16+ parseClientECDHPublic = CKX_ECDH <$> getOpaque8 +decodeFinished :: Get Handshake+decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes)++----------------------------------------------------------------+-- encode HANDSHAKE+ encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = encodeHandshake' o@@ -313,28 +357,25 @@ encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len encodeHandshake' :: Handshake -> ByteString-encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do- putBinaryVersion version- putClientRandom32 random+encodeHandshake' HelloRequest = ""+encodeHandshake' (ClientHello CH{..}) = runPut $ do+ putBinaryVersion chVersion+ putClientRandom32 chRandom putSession chSession- putWords16 chCiphers- putWords8 compressionIDs+ putWords16 $ map fromCipherId chCiphers+ putWords8 chComps putExtensions chExtensions- return ()-encodeHandshake' (ServerHello version random session cipherid compressionID exts) = runPut $ do- putBinaryVersion version- putServerRandom32 random- putSession session- putWord16 cipherid- putWord8 compressionID- putExtensions exts- return ()-encodeHandshake' (Certificate cc) = encodeCertificate cc-encodeHandshake' (ClientKeyXchg ckx) = runPut $ do- case ckx of- CKX_RSA encryptedPreMain -> putBytes encryptedPreMain- CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic- CKX_ECDH bytes -> putOpaque8 bytes+encodeHandshake' (ServerHello SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions+encodeHandshake' (NewSessionTicket life ticket) = runPut $ do+ putWord32 life+ putOpaque16 ticket+encodeHandshake' (Certificate (CertificateChain_ cc)) = encodeCertificate cc encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented"@@ -344,10 +385,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)-encodeHandshake' HelloRequest = ""-encodeHandshake' ServerHelloDone = ""+ _ -> error ("encodeHandshake': cannot handle: " ++ show skg) encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do putWords8 (map fromCertificateType certTypes) putWords16 $@@ -356,14 +394,33 @@ ) sigAlgs putDNames certAuthorities+encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned-encodeHandshake' (Finished opaque) = runPut $ putBytes opaque-encodeHandshake' (NewSessionTicket life ticket) = runPut $ do- putWord32 life- putOpaque16 ticket+encodeHandshake' (ClientKeyXchg ckx) = runPut $ do+ case ckx of+ CKX_RSA encryptedPreMain -> putBytes encryptedPreMain+ CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic+ CKX_ECDH bytes -> putOpaque8 bytes+encodeHandshake' (Finished (VerifyData opaque)) = runPut $ putBytes opaque ------------------------------------------------------------+-- CA distinguished names +-- | Decode a list CA distinguished names+getDNames :: Get [DistinguishedName]+getDNames = do+ dNameLen <- getWord16+ -- FIXME: Decide whether to remove this check completely or to make it an option.+ -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"+ getList (fromIntegral dNameLen) getDName+ where+ getDName = do+ dName <- getOpaque16+ when (B.length dName == 0) $ fail "certrequest: invalid DN length"+ dn <-+ either fail return $ decodeASN1Object "cert request DistinguishedName" dName+ return (2 + B.length dName, dn)+ -- | Encode a list of distinguished names. putDNames :: [DistinguishedName] -> Put putDNames dnames = do@@ -375,6 +432,8 @@ -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1Object dn +------------------------------------------------------------+ {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32@@ -394,17 +453,23 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r +------------------------------------------------------------+ getSession :: Get Session getSession = do 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 putSession (Session (Just s)) = putOpaque8 s +------------------------------------------------------------+ getExtensions :: Int -> Get [ExtensionRaw] getExtensions 0 = return [] getExtensions len = do@@ -421,6 +486,8 @@ putExtensions [] = return () putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) +------------------------------------------------------------+ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- HashAlgorithm <$> getWord8@@ -431,12 +498,16 @@ putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) = putWord8 h >> putWord8 s +------------------------------------------------------------+ getServerDHParams :: Get ServerDHParams getServerDHParams = ServerDHParams <$> getBigNum16 <*> getBigNum16 <*> getBigNum16 putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] +------------------------------------------------------------+ -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do@@ -446,19 +517,20 @@ -- ECParameters ECCurveType: curve name type grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint- case decodeGroupPublic grp mxy of- Left e -> error $ "getServerECDHParams: " ++ show e+ case groupDecodePublicA grp mxy of+ 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 putServerECDHParams (ServerECDHParams (Group grp) grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 grp -- ECParameters NamedCurve- putOpaque8 $ encodeGroupPublic grppub -- ECPoint+ putOpaque8 $ groupEncodePublicA grppub -- ECPoint +------------------------------------------------------------+ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned@@ -469,17 +541,7 @@ putDigitallySigned (DigitallySigned h sig) = putSignatureHashAlgorithm h >> putOpaque16 sig -{-- - decode and encode ALERT- -}--decodeChangeCipherSpec :: ByteString -> Either TLSError ()-decodeChangeCipherSpec = runGetErr "changecipherspec" $ do- x <- getWord8- when (x /= 1) (fail "unknown change cipher spec content")--encodeChangeCipherSpec :: ByteString-encodeChangeCipherSpec = runPut (putWord8 1)+------------------------------------------------------------ -- RSA pre-main secret decodePreMainSecret :: ByteString -> Either TLSError (Version, ByteString)@@ -490,24 +552,8 @@ encodePreMainSecret :: Version -> ByteString -> ByteString encodePreMainSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) --- | in certain cases, we haven't manage to decode ServerKeyExchange properly,--- because the decoding was too eager and the cipher wasn't been set yet.--- we keep the Server Key Exchange in it unparsed format, and this function is--- able to really decode the server key xchange if it's unparsed.-decodeReallyServerKeyXchgAlgorithmData- :: Version- -> CipherKeyExchangeType- -> ByteString- -> Either TLSError ServerKeyXchgAlgorithmData-decodeReallyServerKeyXchgAlgorithmData ver cke =- runGetErr- "server-key-xchg-algorithm-data"- (decodeServerKeyXchgAlgorithmData ver cke)--{-- - generate things for packet content- -}-type PRF = ByteString -> ByteString -> Int -> ByteString+------------------------------------------------------------+-- generate things for packet content -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256.@@ -518,25 +564,23 @@ | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMainSecret_TLS- :: ByteArrayAccess preMain- => PRF- -> preMain+ :: PRF+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) =- prf (B.convert preMainSecret) seed 48+ prf preMainSecret seed 48 where seed = B.concat ["master secret", c, s] generateMainSecret- :: ByteArrayAccess preMain- => Version+ :: Version -> Cipher- -> preMain+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret v c = generateMainSecret_TLS $ getPRF v c generateExtendedMainSecret@@ -545,14 +589,14 @@ -> Cipher -> preMain -> ByteString- -> ByteString+ -> Secret generateExtendedMainSecret v c preMainSecret sessionHash =- getPRF v c (B.convert preMainSecret) seed 48+ getPRF v c (convert preMainSecret) seed 48 where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS- :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString+ :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize = prf mainSecret seed kbsize where@@ -563,33 +607,12 @@ -> Cipher -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret -> Int- -> ByteString+ -> Secret generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c -generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString-generateFinished_TLS prf label mainSecret hashctx = prf mainSecret seed 12- where- seed = B.concat [label, hashFinal hashctx]--generateClientFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateClientFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "client finished"--generateServerFinished- :: Version- -> Cipher- -> ByteString- -> HashCtx- -> ByteString-generateServerFinished ver ciph =- generateFinished_TLS (getPRF ver ciph) "server finished"+------------------------------------------------------------ encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString@@ -610,3 +633,19 @@ encodeCertificate cc = runPut $ putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc++------------------------------------------------------------++-- | in certain cases, we haven't manage to decode ServerKeyExchange properly,+-- because the decoding was too eager and the cipher wasn't been set yet.+-- we keep the Server Key Exchange in it unparsed format, and this function is+-- able to really decode the server key xchange if it's unparsed.+decodeReallyServerKeyXchgAlgorithmData+ :: Version+ -> CipherKeyExchangeType+ -> ByteString+ -> Either TLSError ServerKeyXchgAlgorithmData+decodeReallyServerKeyXchgAlgorithmData ver cke =+ runGetErr+ "server-key-xchg-algorithm-data"+ (decodeServerKeyXchgAlgorithmData ver cke)
Network/TLS/Packet13.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Packet13 ( encodeHandshake13,@@ -9,13 +10,18 @@ encodeCertificate13, ) where +import Codec.Compression.Zlib+import qualified Control.Exception as E import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.X509 ( CertificateChain, CertificateChainRaw (..), decodeCertificateChain, encodeCertificateChain, )+import System.IO.Unsafe+ import Network.TLS.ErrT import Network.TLS.Imports import Network.TLS.Packet@@ -24,6 +30,8 @@ import Network.TLS.Types import Network.TLS.Wire +----------------------------------------------------------------+ encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where@@ -38,37 +46,62 @@ putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString-encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do- putBinaryVersion TLS12- putServerRandom32 random- putSession session- putWord16 cipherId- putWord8 0 -- compressionID nullCompression- putExtensions exts+encodeHandshake13' (ServerHello13 SH{..}) = runPut $ do+ putBinaryVersion shVersion+ putServerRandom32 shRandom+ putSession shSession+ putWord16 $ fromCipherId shCipher+ putWord8 shComp+ putExtensions shExtensions+encodeHandshake13'+ ( NewSessionTicket13+ life+ ageadd+ (TicketNonce nonce)+ (SessionIDorTicket_ label)+ exts+ ) = runPut $ do+ putWord32 life+ putWord32 ageadd+ putOpaque8 nonce+ putOpaque16 label+ putExtensions exts+encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts+encodeHandshake13' (Certificate13 reqctx (CertificateChain_ cc) ess) = encodeCertificate13 reqctx cc ess 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' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do putSignatureHashAlgorithm hs- putOpaque16 signature-encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat-encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do- putWord32 life- putWord32 ageadd- putOpaque8 nonce- putOpaque16 label- putExtensions exts-encodeHandshake13' EndOfEarlyData13 = ""+ putOpaque16 sig+encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1+encodeHandshake13' (CompressedCertificate13 reqctx (CertificateChain_ cc) ess) = runPut $ do+ putWord16 1 -- zlib: fixme+ let bs = encodeCertificate13 reqctx cc ess+ putWord24 $ fromIntegral $ B.length bs+ putOpaque24 $ BL.toStrict $ compress $ BL.fromStrict bs encodeHandshakeHeader13 :: HandshakeType -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do putWord8 (fromHandshakeType ty) putWord24 len +encodeCertificate13+ :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString+encodeCertificate13 reqctx cc ess = runPut $ do+ putOpaque8 reqctx+ putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+ where+ CertificateChainRaw certs = encodeCertificateChain cc+ putCert (certRaw, exts) = do+ putOpaque24 certRaw+ putExtensions exts++----------------------------------------------------------------+ decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of GotError err -> throwError err@@ -86,32 +119,51 @@ content <- getOpaque24 return (ty, content) +{- FOURMOLU_DISABLE -} decodeHandshake13 :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of- HandshakeType_ServerHello -> decodeServerHello13- HandshakeType_Finished -> decodeFinished13- HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13- HandshakeType_CertRequest -> decodeCertRequest13- HandshakeType_Certificate -> decodeCertificate13- HandshakeType_CertVerify -> decodeCertVerify13- HandshakeType_NewSessionTicket -> decodeNewSessionTicket13- HandshakeType_EndOfEarlyData -> return EndOfEarlyData13- HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_ServerHello -> decodeServerHello13+ HandshakeType_NewSessionTicket -> decodeNewSessionTicket13+ HandshakeType_EndOfEarlyData -> return EndOfEarlyData13+ HandshakeType_EncryptedExtensions -> decodeEncryptedExtensions13+ HandshakeType_Certificate -> decodeCertificate13+ HandshakeType_CertRequest -> decodeCertRequest13+ HandshakeType_CertVerify -> decodeCertVerify13+ HandshakeType_Finished -> decodeFinished13+ HandshakeType_KeyUpdate -> decodeKeyUpdate13+ HandshakeType_CompressedCertificate -> decodeCompressedCertificate13 (HandshakeType x) -> fail $ "Unsupported HandshakeType " ++ show x+{- FOURMOLU_ENABLE -} decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do- _ver <- getBinaryVersion+ ver <- getBinaryVersion random <- getServerRandom32 session <- getSession- cipherid <- getWord16- _comp <- getWord8- exts <- fromIntegral <$> getWord16 >>= getExtensions- return $ ServerHello13 random session cipherid exts+ cipherid <- CipherId <$> getWord16+ comp <- getWord8+ exts <- getWord16 >>= getExtensions . fromIntegral+ return $+ ServerHello13 $+ SH+ { shVersion = ver+ , shRandom = random+ , shSession = session+ , shCipher = cipherid+ , shComp = comp+ , shExtensions = exts+ } -decodeFinished13 :: Get Handshake13-decodeFinished13 = Finished13 <$> (remaining >>= getBytes)+decodeNewSessionTicket13 :: Get Handshake13+decodeNewSessionTicket13 = do+ life <- getWord32+ ageadd <- getWord32+ nonce <- TicketNonce <$> getOpaque8+ label <- SessionIDorTicket_ <$> getOpaque16+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ NewSessionTicket13 life ageadd nonce label exts decodeEncryptedExtensions13 :: Get Handshake13 decodeEncryptedExtensions13 =@@ -119,13 +171,6 @@ len <- fromIntegral <$> getWord16 getExtensions len -decodeCertRequest13 :: Get Handshake13-decodeCertRequest13 = do- reqctx <- getOpaque8- len <- fromIntegral <$> getWord16- exts <- getExtensions len- return $ CertRequest13 reqctx exts- decodeCertificate13 :: Get Handshake13 decodeCertificate13 = do reqctx <- getOpaque8@@ -133,7 +178,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 (CertificateChain_ cc) ess where getCert = do l <- fromIntegral <$> getWord24@@ -142,19 +187,20 @@ exts <- getExtensions len return (3 + l + 2 + len, (cert, exts)) -decodeCertVerify13 :: Get Handshake13-decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16--decodeNewSessionTicket13 :: Get Handshake13-decodeNewSessionTicket13 = do- life <- getWord32- ageadd <- getWord32- nonce <- getOpaque8- label <- getOpaque16+decodeCertRequest13 :: Get Handshake13+decodeCertRequest13 = do+ reqctx <- getOpaque8 len <- fromIntegral <$> getWord16 exts <- getExtensions len- return $ NewSessionTicket13 life ageadd nonce label exts+ return $ CertRequest13 reqctx exts +decodeCertVerify13 :: Get Handshake13+decodeCertVerify13 =+ CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16)++decodeFinished13 :: Get Handshake13+decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes)+ decodeKeyUpdate13 :: Get Handshake13 decodeKeyUpdate13 = do ru <- getWord8@@ -163,13 +209,25 @@ 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x -encodeCertificate13- :: CertReqContext -> CertificateChain -> [[ExtensionRaw]] -> ByteString-encodeCertificate13 reqctx cc ess = runPut $ do- putOpaque8 reqctx- putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+decodeCompressedCertificate13 :: Get Handshake13+decodeCompressedCertificate13 = do+ algo <- getWord16+ when (algo /= 1) $ fail "comp algo is not supported" -- fixme+ len <- getWord24+ bs <- getOpaque24+ if bs == ""+ then fail "empty compressed certificate"+ else case decompressIt bs of+ Left e -> fail (show e)+ Right bs' -> do+ when (B.length bs' /= len) $ fail "plain length is wrong"+ case runGetMaybe decodeCertificate13 bs' of+ Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess+ -- _ -> fail "compressed certificate cannot be parsed"+ _ -> fail $ "invalid compressed certificate: len = " ++ show len++decompressIt :: ByteString -> Either DecompressError ByteString+decompressIt inp = unsafePerformIO $ E.handle handler $ do+ Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp)) where- CertificateChainRaw certs = encodeCertificateChain cc- putCert (certRaw, exts) = do- putOpaque24 certRaw- putExtensions exts+ handler e = return $ Left (e :: DecompressError)
Network/TLS/Parameters.hs view
@@ -1,17 +1,26 @@+{-# LANGUAGE Strict #-}+ module Network.TLS.Parameters ( ClientParams (..),+ defaultParamsClient, ServerParams (..),+ defaultParamsServer, CommonParams, DebugParams (..),+ defaultDebugParams,+ defaultKeyLogger, ClientHooks (..),+ defaultClientHooks, OnCertificateRequest, OnServerCertificate, ServerHooks (..),+ defaultServerHooks, Supported (..),+ defaultSupported, Shared (..),-- -- * special default- defaultParamsClient,+ defaultShared,+ Limit (..),+ defaultLimit, -- * Parameters MaxFragmentEnum (..),@@ -19,15 +28,23 @@ GroupUsage (..), CertificateUsage (..), CertificateRejectReason (..),+ Information (..), ) where -import qualified Data.ByteString as B-import Data.Default.Class+import Control.Concurrent (MVar, newMVar, withMVar)+import Crypto.HPKE+import Data.Default (Default (def))+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto+import Network.TLS.ECH.Config import Network.TLS.Extension+import Network.TLS.Extra.Cipher+import Network.TLS.Handshake.State import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.RNG (Seed)@@ -48,7 +65,7 @@ -- -- Default: 'Nothing' , debugPrintSeed :: Seed -> IO ()- -- ^ Add a way to print the seed that was randomly generated. re-using the same seed+ -- ^ Add a way to print the seed that was randomly generated. reusing the same seed -- will reproduce the same randomness with 'debugSeed' -- -- Default: no printing@@ -60,15 +77,34 @@ -- ^ Printing main keys. -- -- Default: no printing+ , debugError :: String -> IO ()+ , debugTraceKey :: String -> IO () } +{-# NOINLINE keyLogLock #-}+keyLogLock :: MVar ()+keyLogLock = unsafePerformIO $ newMVar ()++{-# NOINLINE keyLogFile #-}+keyLogFile :: Maybe FilePath+keyLogFile = unsafePerformIO $ lookupEnv "SSLKEYLOGFILE"++-- | Key logger with the SSLKEYLOGFILE environment variable.+defaultKeyLogger :: String -> IO ()+defaultKeyLogger ~msg = case keyLogFile of+ Nothing -> return ()+ Just file -> withMVar keyLogLock $ \_ -> appendFile file (msg ++ "\n")++-- | Default value for 'DebugParams' defaultDebugParams :: DebugParams defaultDebugParams = DebugParams { debugSeed = Nothing , debugPrintSeed = const (return ()) , debugVersionForced = Nothing- , debugKeyLogger = \_ -> return ()+ , debugKeyLogger = defaultKeyLogger+ , debugError = \ ~_ -> return ()+ , debugTraceKey = \ ~_ -> return () } instance Show DebugParams where@@ -76,53 +112,88 @@ instance Default DebugParams where def = defaultDebugParams +{-# DEPRECATED clientUseMaxFragmentLength "UseMaxFragmentLength is deprecated" #-}+ data ClientParams = ClientParams { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum -- ^ -- -- Default: 'Nothing' , clientServerIdentification :: (HostName, ByteString)- -- ^ Define the name of the server, along with an extra service identification blob.- -- this is important that the hostname part is properly filled for security reason,- -- as it allow to properly associate the remote side with the given certificate- -- during a handshake.+ -- ^ Define the name of the server, along with an extra service+ -- identification blob. this is important that the hostname part+ -- is properly filled for security reason, as it allow to properly+ -- associate the remote side with the given certificate during a+ -- handshake. --- -- The extra blob is useful to differentiate services running on the same host, but that- -- might have different certificates given. It's only used as part of the X509 validation+ -- The extra blob is useful to differentiate services running on+ -- the same host, but that might have different certificates+ -- given. It's only used as part of the X509 validation -- infrastructure. -- -- This value is typically set by 'defaultParamsClient'. , clientUseServerNameIndication :: Bool- -- ^ Allow the use of the Server Name Indication TLS extension during handshake, which allow- -- the client to specify which host name, it's trying to access. This is useful to distinguish+ -- ^ Allow the use of the Server Name Indication TLS extension+ -- during handshake, which allow the client to specify which host+ -- name, it's trying to access. This is useful to distinguish -- CNAME aliasing (e.g. web virtual host). -- -- Default: 'True' , clientWantSessionResume :: Maybe (SessionID, SessionData)- -- ^ try to establish a connection using this session.+ -- ^ try to establish a connection using this session for TLS+ -- 1.2/TLS 1.3. This can be used for TLS 1.3 but for backward+ -- compatibility purpose only. Use 'clientWantSessionResume13'+ -- instead for TLS 1.3. -- -- Default: 'Nothing'+ , clientWantSessionResumeList :: [(SessionID, SessionData)]+ -- ^ try to establish a connection using one of this sessions+ -- especially for TLS 1.3. This take precedence over+ -- 'clientWantSessionResume'. For convenience, this can be+ -- specified for TLS 1.2 but only the first entry is used.+ --+ -- Default: '[]'+ , clientWantTicket :: Bool+ -- ^ Whether to solicit TLS 1.2 session tickets (or TLS 1.3+ -- resumption PSKs) from servers. With a 'False' setting,+ -- stateless clients that never do resumption can avoid+ -- wasting server and client resources used to generate,+ -- transmit and process tickets that will never be used.+ --+ -- Default: 'True'+ --+ -- @since 2.4.1 , clientShared :: Shared -- ^ See the default value of 'Shared'. , clientHooks :: ClientHooks -- ^ See the default value of 'ClientHooks'. , clientSupported :: Supported- -- ^ In this element, you'll need to override the default empty value of- -- of 'supportedCiphers' with a suitable cipherlist.+ -- ^ In this element, you'll need to override the default empty+ -- value of of 'supportedCiphers' with a suitable cipherlist. -- -- See the default value of 'Supported'. , clientDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , clientUseEarlyData :: Bool- -- ^ Client tries to send early data in TLS 1.3- -- via 'sendData' if possible.- -- If not accepted by the server, the early data- -- is automatically re-sent.+ -- ^ Client tries to send early data in TLS 1.3 via 'sendData' if+ -- possible. If not accepted by the server, the early data is+ -- automatically re-sent. -- -- Default: 'False'+ , clientUseECH :: Bool+ -- ^ Enabling Encrypted Client Hello.+ -- If 'sharedECHConfigList' is null, a greasing ECH extension is sent.+ -- Otherwise, a valid ECH is sent.+ -- If the server rejects ECH in Server Hello,+ -- the client sends an alert after negotiation.+ --+ -- Default: 'False'+ --+ -- @since 2.1.9 } deriving (Show) +-- | Default value for 'ClientParams' defaultParamsClient :: HostName -> ByteString -> ClientParams defaultParamsClient serverName serverId = ClientParams@@ -130,11 +201,14 @@ , clientServerIdentification = (serverName, serverId) , clientUseServerNameIndication = True , clientWantSessionResume = Nothing+ , clientWantSessionResumeList = []+ , clientWantTicket = True , clientShared = def , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams , clientUseEarlyData = False+ , clientUseECH = False } data ServerParams = ServerParams@@ -143,15 +217,15 @@ -- -- Default: 'False' , serverCACertificates :: [SignedCertificate]- -- ^ This is a list of certificates from which the- -- disinguished names are sent in certificate request- -- messages. For TLS1.0, it should not be empty.+ -- ^ This is a list of certificates from which the disinguished+ -- names are sent in certificate request messages. For TLS1.0, it+ -- should not be empty. -- -- Default: '[]' , serverDHEParams :: Maybe DHParams- -- ^ Server Optional Diffie Hellman parameters. Setting parameters is- -- necessary for FFDHE key exchange when clients are not compatible- -- with RFC 7919.+ -- ^ Server Optional Diffie Hellman parameters. Setting+ -- parameters is necessary for FFDHE key exchange when clients are+ -- not compatible with RFC 7919. -- -- Value can be one of the standardized groups from module -- "Network.TLS.Extra.FFDHE" or custom parameters generated with@@ -167,15 +241,21 @@ , serverDebug :: DebugParams -- ^ See the default value of 'DebugParams'. , serverEarlyDataSize :: Int- -- ^ Server accepts this size of early data in TLS 1.3.- -- 0 (or lower) means that the server does not accept early data.+ -- ^ Server accepts this size of early data in TLS 1.3. 0 (or+ -- lower) means that the server does not accept early data. -- -- Default: 0 , serverTicketLifetime :: Int- -- ^ Lifetime in seconds for session tickets generated by the server.- -- Acceptable value range is 0 to 604800 (7 days).+ -- ^ Lifetime in seconds for session tickets generated by the+ -- server. Acceptable value range is 0 to 604800 (7 days). -- -- Default: 7200 (2 hours)+ , serverECHKey :: [(ConfigId, ByteString)]+ -- ^ ECH secret keys.+ --+ -- Default: '[]'+ --+ -- @since 2.1.9 } deriving (Show) @@ -191,6 +271,7 @@ , serverDebug = defaultDebugParams , serverEarlyDataSize = 0 , serverTicketLifetime = 7200+ , serverECHKey = [] } instance Default ServerParams where@@ -199,26 +280,27 @@ -- | List all the supported algorithms, versions, ciphers, etc supported. data Supported = Supported { supportedVersions :: [Version]- -- ^ Supported versions by this context. On the client side, the highest- -- version will be used to establish the connection. On the server side,- -- the highest version that is less or equal than the client version will- -- be chosen.+ -- ^ Supported versions by this context. On the client side, the+ -- highest version will be used to establish the connection. On+ -- the server side, the highest version that is less or equal than+ -- the client version will be chosen. --- -- Versions should be listed in preference order, i.e. higher versions- -- first.+ -- Versions should be listed in preferred order, i.e. higher+ -- versions first. -- -- Default: @[TLS13,TLS12]@ , supportedCiphers :: [Cipher]- -- ^ Supported cipher methods. The default is empty, specify a suitable- -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often- -- a good choice.+ -- ^ Supported cipher methods. The default is empty, specify a+ -- suitable cipher list.+ -- 'Network.TLS.Extra.Cipher.ciphersuite_default' is often a good+ -- choice. -- -- Default: @[]@ , supportedCompressions :: [Compression] -- ^ Supported compressions methods. By default only the "null"- -- compression is supported, which means no compression will be performed.- -- Allowing other compression method is not advised as it causes a- -- connection failure when TLS 1.3 is negotiated.+ -- compression is supported, which means no compression will be+ -- performed. Allowing other compression method is not advised as+ -- it causes a connection failure when TLS 1.3 is negotiated. -- -- Default: @[nullCompression]@ , supportedHashSignatures :: [HashAndSignatureAlgorithm]@@ -226,18 +308,19 @@ -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. --- -- This list is sent to the peer as part of the "signature_algorithms"- -- extension. It is used to restrict accepted signatures received from- -- the peer at TLS level (not in X.509 certificates), but only when the- -- TLS version is 1.2 or above. In order to disable SHA-1 one must then- -- also disable earlier protocol versions in 'supportedVersions'.+ -- This list is sent to the peer as part of the+ -- "signature_algorithms" extension. It is used to restrict+ -- accepted signatures received from the peer at TLS level (not in+ -- X.509 certificates), but only when the TLS version is 1.2 or+ -- above. In order to disable SHA-1 one must then also disable+ -- earlier protocol versions in 'supportedVersions'. -- -- The list also impacts the selection of possible algorithms when -- generating signatures. --- -- Note: with TLS 1.3 some algorithms have been deprecated and will not be- -- used even when listed in the parameter: MD5, SHA-1, SHA-224, RSA- -- PKCS#1, DSA.+ -- Note: with TLS 1.3 some algorithms have been deprecated and+ -- will not be used even when listed in the parameter: MD5, SHA-1,+ -- SHA-224, RSA PKCS#1, DSA. -- -- Default: --@@ -258,62 +341,87 @@ -- ] -- @ , supportedSecureRenegotiation :: Bool- -- ^ Secure renegotiation defined in RFC5746.- -- If 'True', clients send the renegotiation_info extension.- -- If 'True', servers handle the extension or the renegotiation SCSV- -- then send the renegotiation_info extension.+ -- ^ Secure renegotiation defined in RFC5746. If 'True', clients+ -- send the renegotiation_info extension. If 'True', servers+ -- handle the extension or the renegotiation SCSV then send the+ -- renegotiation_info extension. -- -- Default: 'True' , supportedClientInitiatedRenegotiation :: Bool -- ^ If 'True', renegotiation is allowed from the client side.- -- This is vulnerable to DOS attacks.- -- If 'False', renegotiation is allowed only from the server side- -- via HelloRequest.+ -- This is vulnerable to DOS attacks. If 'False', renegotiation+ -- is allowed only from the server side via HelloRequest. -- -- Default: 'False' , supportedExtendedMainSecret :: EMSMode- -- ^ The mode regarding extended main secret. Enabling this extension- -- provides better security for TLS versions 1.2. TLS 1.3 provides- -- the security properties natively and does not need the extension.- --- -- By default the extension is 'RequireEMS'.- -- So, the handshake will fail when the peer does not support+ -- ^ The mode regarding extended main secret. Enabling this+ -- extension provides better security for TLS versions 1.2. TLS+ -- 1.3 provides the security properties natively and does not need -- the extension. --+ -- By default the extension is 'RequireEMS'. So, the handshake+ -- will fail when the peer does not support the extension.+ -- -- Default: 'RequireEMS' , supportedSession :: Bool -- ^ Set if we support session. -- -- Default: 'True' , supportedFallbackScsv :: Bool- -- ^ Support for fallback SCSV defined in RFC7507.- -- If 'True', servers reject handshakes which suggest- -- a lower protocol than the highest protocol supported.+ -- ^ Support for fallback SCSV defined in RFC7507. If 'True',+ -- servers reject handshakes which suggest a lower protocol than+ -- the highest protocol supported. -- -- Default: 'True' , supportedEmptyPacket :: Bool- -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC residue as IV, which can be guessed- -- by an attacker. Hence, an empty packet is normally sent before a normal data packet, to- -- prevent guessability. Some Microsoft TLS-based protocol implementations, however,- -- consider these empty packets as a protocol violation and disconnect. If this parameter is- -- 'False', empty packets will never be added, which is less secure, but might help in rare- -- cases.+ -- ^ In ver <= TLS1.0, block ciphers using CBC are using CBC+ -- residue as IV, which can be guessed by an attacker. Hence, an+ -- empty packet is normally sent before a normal data packet, to+ -- prevent guessability. Some Microsoft TLS-based protocol+ -- implementations, however, consider these empty packets as a+ -- protocol violation and disconnect. If this parameter is+ -- 'False', empty packets will never be added, which is less+ -- secure, but might help in rare cases. -- -- Default: 'True'+ , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -- ^ Client only.+ --+ -- @since 2.1.9 , supportedGroups :: [Group]- -- ^ A list of supported elliptic curves and finite-field groups in the- -- preferred order.+ -- ^ A list of supported elliptic curves and finite-field groups+ -- in preferred order. --- -- The list is sent to the server as part of the "supported_groups"- -- extension. It is used in both clients and servers to restrict- -- accepted groups in DH key exchange. Up until TLS v1.2, it is also- -- used by a client to restrict accepted elliptic curves in ECDSA- -- signatures.+ -- * TLS 1.3 client: this list is used as the 1st argument to+ -- 'onSelectKeyShareGroups' to select groups in "key_share".+ -- This list is also used as values of "supported_groups".+ -- * TLS 1.3 server: this list is not used.+ -- * TLS 1.2 client: this list is also used as values of+ -- "supported_groups".+ -- * TLS 1.2 server: this list is used to select a key exchange+ -- mechanism. --- -- The default value includes all groups with security strength of 128- -- bits or more.+ -- The list is sent to the server as part of the+ -- "supported_groups" extension. It is used in both clients and+ -- servers to restrict accepted groups in DH key exchange. Up+ -- until TLS v1.2, it is also used by a client to restrict+ -- accepted elliptic curves in ECDSA signatures. --- -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@+ -- The default value includes all groups with security strength+ -- of 128 bits or more.+ --+ -- Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@+ , supportedGroupsTLS13 :: [[Group]]+ -- ^ The inside @[Group]@ is the list of @Group@ at the same level+ -- in preferred order. The inside @[Group]@s are also listed in+ -- preferred order.+ --+ -- TLS 1.3 server: this is used as the 1st argument to+ -- 'onSelectKeyShare'.+ --+ -- Default: @[[X25519MLKEM768,P256MLKEM768,P384MLKEM1024],[X25519,P256],[P384,X448,P521],[FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192],[MLKEM768,MLKEM1024]]@+ --+ -- @since 2.2.3 } deriving (Show, Eq) @@ -327,11 +435,21 @@ RequireEMS deriving (Show, Eq) +defaultHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+defaultHPKE =+ [ (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_X25519_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA512, AES_128_GCM)+ , (DHKEM_P256_HKDF_SHA256, HKDF_SHA256, ChaCha20Poly1305)+ , (DHKEM_P521_HKDF_SHA512, HKDF_SHA512, AES_256_GCM)+ ]+ defaultSupported :: Supported defaultSupported = Supported { supportedVersions = [TLS13, TLS12]- , supportedCiphers = []+ , supportedCiphers = ciphersuite_default , supportedCompressions = [nullCompression] , supportedHashSignatures = Struct.supportedSignatureSchemes , supportedSecureRenegotiation = True@@ -340,7 +458,9 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True+ , supportedHPKE = defaultHPKE , supportedGroups = supportedNamedGroups+ , supportedGroupsTLS13 = supportedNamedGroupsTLS13 } instance Default Supported where@@ -349,11 +469,11 @@ -- | Parameters that are common to clients and servers. data Shared = Shared { sharedCredentials :: Credentials- -- ^ The list of certificates and private keys that a server will use as- -- part of authentication to clients. Actual credentials that are used- -- are selected dynamically from this list based on client capabilities.- -- Additional credentials returned by 'onServerNameIndication' are also- -- considered.+ -- ^ The list of certificates and private keys that a server will+ -- use as part of authentication to clients. Actual credentials+ -- that are used are selected dynamically from this list based on+ -- client capabilities. Additional credentials returned by+ -- 'onServerNameIndication' are also considered. -- -- When credential list is left empty (the default value), no key -- exchange can take place.@@ -361,49 +481,63 @@ -- Default: 'mempty' , sharedSessionManager :: SessionManager -- ^ Callbacks used by clients and servers in order to resume TLS- -- sessions. The default implementation never resumes sessions. Package- -- <https://hackage.haskell.org/package/tls-session-manager tls-session-manager>- -- provides an in-memory implementation.+ -- sessions. The default implementation never resumes sessions.+ -- Package+ -- <https://hackage.haskell.org/package/tls-session-manager+ -- tls-session-manager> provides an in-memory implementation. -- -- Default: 'noSessionManager' , sharedCAStore :: CertificateStore- -- ^ A collection of trust anchors to be used by a client as- -- part of validation of server certificates. This is set as- -- first argument to function 'onServerCertificate'. Package- -- <https://hackage.haskell.org/package/crypton-x509-system crypton-x509-system>- -- gives access to a default certificate store configured in the- -- system.+ -- ^ A collection of trust anchors to be used by a client as part+ -- of validation of server certificates. This is set as first+ -- argument to function 'onServerCertificate'. Package+ -- <https://hackage.haskell.org/package/crypton-x509-system+ -- crypton-x509-system> gives access to a default certificate+ -- store configured in the system. -- -- Default: 'mempty' , sharedValidationCache :: ValidationCache -- ^ Callbacks that may be used by a client to cache certificate -- validation results (positive or negative) and avoid expensive- -- signature check. The default implementation does not have- -- any caching.+ -- signature check. The default implementation does not have any+ -- caching. -- -- See the default value of 'ValidationCache'. , sharedHelloExtensions :: [ExtensionRaw] -- ^ Additional extensions to be sent during the Hello sequence. --- -- For a client this is always included in message ClientHello. For a- -- server, this is sent in messages ServerHello or EncryptedExtensions- -- based on the TLS version.+ -- For a client this is always included in message ClientHello.+ -- For a server, this is sent in messages ServerHello or+ -- EncryptedExtensions based on the TLS version. -- -- Default: @[]@+ , sharedECHConfigList :: ECHConfigList+ -- ^ ECH configuration.+ --+ -- @since 2.1.9+ , sharedLimit :: Limit+ -- ^ Limitation parameters.+ --+ -- @since 2.1.8 } instance Show Shared where show _ = "Shared" instance Default Shared where- def =- Shared- { sharedCredentials = mempty- , sharedSessionManager = noSessionManager- , sharedCAStore = mempty- , sharedValidationCache = def- , sharedHelloExtensions = []- }+ def = defaultShared +defaultShared :: Shared+defaultShared =+ Shared+ { sharedCredentials = mempty+ , sharedSessionManager = noSessionManager+ , sharedCAStore = mempty+ , sharedValidationCache = def+ , sharedHelloExtensions = []+ , sharedECHConfigList = []+ , sharedLimit = defaultLimit+ }+ -- | Group usage callback possible return values. data GroupUsage = -- | usage of group accepted@@ -451,91 +585,128 @@ { onCertificateRequest :: OnCertificateRequest -- ^ This action is called when the a certificate request is -- received from the server. The callback argument is the- -- information from the request. The server, at its- -- discretion, may be willing to continue the handshake- -- without a client certificate. Therefore, the callback is- -- free to return 'Nothing' to indicate that no client- -- certificate should be sent, despite the server's request.- -- In some cases it may be appropriate to get user consent- -- before sending the certificate; the content of the user's- -- certificate may be sensitive and intended only for- -- specific servers.+ -- information from the request. The server, at its discretion,+ -- may be willing to continue the handshake without a client+ -- certificate. Therefore, the callback is free to return+ -- 'Nothing' to indicate that no client certificate should be+ -- sent, despite the server's request. In some cases it may be+ -- appropriate to get user consent before sending the certificate;+ -- the content of the user's certificate may be sensitive and+ -- intended only for specific servers. --- -- The action should select a certificate chain of one of- -- the given certificate types and one of the certificates- -- in the chain should (if possible) be signed by one of the- -- given distinguished names. Some servers, that don't have- -- a narrow set of preferred issuer CAs, will send an empty- -- 'DistinguishedName' list, rather than send all the names- -- from their trusted CA bundle. If the client does not- -- have a certificate chaining to a matching CA, it may- -- choose a default certificate instead.+ -- The action should select a certificate chain of one of the+ -- given certificate types and one of the certificates in the+ -- chain should (if possible) be signed by one of the given+ -- distinguished names. Some servers, that don't have a narrow+ -- set of preferred issuer CAs, will send an empty+ -- 'DistinguishedName' list, rather than send all the names from+ -- their trusted CA bundle. If the client does not have a+ -- certificate chaining to a matching CA, it may choose a default+ -- certificate instead. -- -- Each certificate except the last should be signed by the- -- following one. The returned private key must be for the- -- first certificates in the chain. This key will be used- -- to signing the certificate verify message.+ -- following one. The returned private key must be for the first+ -- certificates in the chain. This key will be used to signing+ -- the certificate verify message. -- -- The public key in the first certificate, and the matching- -- returned private key must be compatible with one of the- -- list of 'HashAndSignatureAlgorithm' value when provided.- -- TLS 1.3 changes the meaning of the list elements, adding- -- explicit code points for each supported pair of hash and- -- signature (public key) algorithms, rather than combining- -- separate codes for the hash and key. For details see+ -- returned private key must be compatible with one of the list of+ -- 'HashAndSignatureAlgorithm' value when provided. TLS 1.3+ -- changes the meaning of the list elements, adding explicit code+ -- points for each supported pair of hash and signature (public+ -- key) algorithms, rather than combining separate codes for the+ -- hash and key. For details see -- <https://tools.ietf.org/html/rfc8446#section-4.2.3 RFC 8446> -- section 4.2.3. When no compatible certificate chain is- -- available, return 'Nothing' if it is OK to continue- -- without a client certificate. Returning a non-matching- -- certificate should result in a handshake failure.+ -- available, return 'Nothing' if it is OK to continue without a+ -- client certificate. Returning a non-matching certificate+ -- should result in a handshake failure. --- -- While the TLS version is not provided to the callback,- -- the content of the @signature_algorithms@ list provides- -- a strong hint, since TLS 1.3 servers will generally list- -- RSA pairs with a hash component of 'Intrinsic' (@0x08@).+ -- While the TLS version is not provided to the callback, the+ -- content of the @signature_algorithms@ list provides a strong+ -- hint, since TLS 1.3 servers will generally list RSA pairs with+ -- a hash component of 'Intrinsic' (@0x08@). --- -- Note that is is the responsibility of this action to- -- select a certificate matching one of the requested- -- certificate types (public key algorithms). Returning- -- a non-matching one will lead to handshake failure later.+ -- Note that is is the responsibility of this action to select a+ -- certificate matching one of the requested certificate types+ -- (public key algorithms). Returning a non-matching one will+ -- lead to handshake failure later. -- -- Default: returns 'Nothing' anyway. , onServerCertificate :: OnServerCertificate- -- ^ Used by the client to validate the server certificate. The default- -- implementation calls 'validateDefault' which validates according to the- -- default hooks and checks provided by "Data.X509.Validation". This can- -- be replaced with a custom validation function using different settings.+ -- ^ Used by the client to validate the server certificate. The+ -- default implementation calls 'validateDefault' which validates+ -- according to the default hooks and checks provided by+ -- "Data.X509.Validation". This can be replaced with a custom+ -- validation function using different settings. --- -- The function is not expected to verify the key-usage extension of the- -- end-entity certificate, as this depends on the dynamically-selected- -- cipher and this part should not be cached. Key-usage verification- -- is performed by the library internally.+ -- The function is not expected to verify the key-usage extension+ -- of the end-entity certificate, as this depends on the+ -- dynamically-selected cipher and this part should not be cached.+ -- Key-usage verification is performed by the library internally. -- -- Default: 'validateDefault'- , onSuggestALPN :: IO (Maybe [B.ByteString])+ , onSuggestALPN :: IO (Maybe [ByteString]) -- ^ This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. -- -- Default: returns 'Nothing' , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage- -- ^ This action is called to validate DHE parameters when the server- -- selected a finite-field group not part of the "Supported Groups- -- Registry" or not part of 'supportedGroups' list.+ -- ^ This action is called to validate DHE parameters when the+ -- server selected a finite-field group not part of the+ -- "Supported Groups Registry" or not part of 'supportedGroups'+ -- list. --- -- With TLS 1.3 custom groups have been removed from the protocol, so- -- this callback is only used when the version negotiated is 1.2 or- -- below.+ -- With TLS 1.3 custom groups have been removed from the+ -- protocol, so this callback is only used when the version+ -- negotiated is 1.2 or below. --- -- The default behavior with (dh_p, dh_g, dh_size) and pub as follows:+ -- The default behavior with (dh_p, dh_g, dh_size) and pub as+ -- follows: -- -- (1) rejecting if dh_p is even -- (2) rejecting unless 1 < dh_g && dh_g < dh_p - 1 -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1 -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) --- -- See RFC 7919 section 3.1 for recommandations.+ -- See RFC 7919 section 3.1 for recommendations.+ , onServerFinished :: Information -> IO ()+ -- ^ When a handshake is done, this hook can check `Information`.+ , onSelectKeyShareGroups :: [Group] -> [Group]+ -- ^ A function to select groups in "key_share" by TLS 1.3 client.+ --+ -- Client's 'supportedGroups' is passed as the 1st argument.+ --+ -- The default function specifies a pair of hybrid (classical ++ -- post quantum) group and classical group to transit from+ -- classical key exchange to hybrid key exchange. With the+ -- default value of 'supportedGroups', X25519MLKEM and X25519+ -- are chosen.+ --+ -- Middleboxes may drop a ClientHello that contains large+ -- X2219MLKEM. In such environment, @take 1@, which selects+ -- X22519 only with the default value, is maybe a good+ -- candidate.+ --+ -- In the case where X22519 is only contained in "key_share", a+ -- wise-server without nasty middleboxes may ask the client to+ -- send X2219MLKEM via HelloRetryRequest as X2219MLKEM is+ -- specified in "supported_groups".+ --+ -- @since 2.2.3 } +defaultOnSelectKeyShareGroups :: [Group] -> [Group]+defaultOnSelectKeyShareGroups groups = take 1 hs ++ take 1 es+ where+ (hs, es) = partition isHybrid groups++isHybrid :: Group -> Bool+isHybrid X25519MLKEM768 = True+isHybrid P256MLKEM768 = True+isHybrid P384MLKEM1024 = True+isHybrid _ = False+ defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks@@ -543,6 +714,8 @@ , onServerCertificate = validateDefault , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024+ , onServerFinished = \_ -> return ()+ , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups } instance Show ClientHooks where@@ -553,58 +726,58 @@ -- | A set of callbacks run by the server for various corners of the TLS establishment data ServerHooks = ServerHooks { onClientCertificate :: CertificateChain -> IO CertificateUsage- -- ^ This action is called when a client certificate chain- -- is received from the client. When it returns a+ -- ^ This action is called when a client certificate chain is+ -- received from the client. When it returns a -- CertificateUsageReject value, the handshake is aborted. --- -- The function is not expected to verify the key-usage- -- extension of the certificate. This verification is- -- performed by the library internally.+ -- The function is not expected to verify the key-usage extension+ -- of the certificate. This verification is performed by the+ -- library internally. --- -- Default: returns the followings:+ -- Default: returns the following: -- -- @ -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") -- @ , onUnverifiedClientCert :: IO Bool- -- ^ This action is called when the client certificate- -- cannot be verified. Return 'True' to accept the certificate- -- anyway, or 'False' to fail verification.+ -- ^ This action is called when the client certificate cannot be+ -- verified. Return 'True' to accept the certificate anyway, or+ -- 'False' to fail verification. -- -- Default: returns 'False' , onCipherChoosing :: Version -> [Cipher] -> Cipher- -- ^ Allow the server to choose the cipher relative to the- -- the client version and the client list of ciphers.+ -- ^ Allow the server to choose the cipher relative to the the+ -- client version and the client list of ciphers. --- -- This could be useful with old clients and as a workaround- -- to the BEAST (where RC4 is sometimes prefered with TLS < 1.1)+ -- This could be useful with old clients and as a workaround to+ -- the BEAST (where RC4 is sometimes preferred with TLS < 1.1) -- -- The client cipher list cannot be empty. -- -- Default: taking the head of ciphers. , onServerNameIndication :: Maybe HostName -> IO Credentials- -- ^ Allow the server to indicate additional credentials- -- to be used depending on the host name indicated by the- -- client.+ -- ^ Allow the server to indicate additional credentials to be+ -- used depending on the host name indicated by the client. --- -- This is most useful for transparent proxies where- -- credentials must be generated on the fly according to- -- the host the client is trying to connect to.+ -- This is most useful for transparent proxies where credentials+ -- must be generated on the fly according to the host the client+ -- is trying to connect to. --- -- Returned credentials may be ignored if a client does not support- -- the signature algorithms used in the certificate chain.+ -- Returned credentials may be ignored if a client does not+ -- support the signature algorithms used in the certificate chain. -- -- Default: returns 'mempty' , onNewHandshake :: Measurement -> IO Bool- -- ^ At each new handshake, we call this hook to see if we allow handshake to happens.+ -- ^ At each new handshake, we call this hook to see if we allow+ -- handshake to happens. -- -- Default: returns 'True'- , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)+ , onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString) -- ^ Allow the server to choose an application layer protocol- -- suggested from the client through the ALPN- -- (Application Layer Protocol Negotiation) extensions.- -- If the server supports no protocols that the client advertises- -- an empty 'ByteString' should be returned.+ -- suggested from the client through the ALPN (Application Layer+ -- Protocol Negotiation) extensions. If the server supports no+ -- protocols that the client advertises an empty 'ByteString'+ -- should be returned. -- -- Default: 'Nothing' , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw]@@ -612,8 +785,32 @@ -- of TLS 1.3. -- -- Default: 'return'+ , onSelectKeyShare+ :: [[Group]]+ -> [Group]+ -> [Group]+ -> IO (Maybe Group, Bool)+ -- ^ A function to select one key share by TLS 1.3 server.+ --+ -- The 1st argument is server's 'supportedGroupsTLS13'.+ -- The 2nd arguments is client's groups in "supported_groups"+ -- The 3rd arguments is client's groups in "key_share".+ --+ -- 'True' in the result indicates sending a hello retry request+ -- with this group.+ --+ -- The default function targets @[Group]@ in the first argument in+ -- order. If there is a common group among the "key_share"+ -- groups, it will use that group for key exchange.+ -- Alternatively, if there is a common group among the+ -- "supported_groups" groups, it will instruct to send the+ -- HelloRetryRequest using that group. Otherwise, it will check+ -- the next @[Group]@.+ --+ -- @since 2.2.3 } +-- | Default value for 'ServerHooks' defaultServerHooks :: ServerHooks defaultServerHooks = ServerHooks@@ -622,14 +819,81 @@ 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 , onEncryptedExtensionsCreating = return+ , onSelectKeyShare = defaultOnSelectKeyShare } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks++defaultOnSelectKeyShare+ :: [[Group]] -- Server groups+ -> [Group] -- Client's groups in "supported_groups"+ -> [Group] -- Client's groups in "key_share"+ -> IO (Maybe Group, Bool)+defaultOnSelectKeyShare serverSupportedLoL clientSupportedGroups clientKeyShareGroups = go serverSupportedLoL+ where+ go [] = return (Nothing, False)+ go (gs : gss) = case gs `intersect` clientKeyShareGroups of+ [] -> case gs `intersect` clientSupportedGroups of+ [] -> go gss+ h : _ -> return (Just h, True)+ g : _ -> return (Just g, False)++-- | Information related to a running context, e.g. current cipher+data Information = Information+ { infoVersion :: Version+ , infoCipher :: Cipher+ , infoCompression :: Compression+ , infoMainSecret :: Maybe ByteString+ , infoExtendedMainSecret :: Bool+ , infoClientRandom :: Maybe ClientRandom+ , infoServerRandom :: Maybe ServerRandom+ , infoSupportedGroup :: Maybe Group+ , infoTLS12Resumption :: Bool+ , infoTLS13HandshakeMode :: Maybe HandshakeMode13+ , infoIsEarlyDataAccepted :: Bool+ , infoIsECHAccepted :: Bool+ }+ deriving (Show, Eq)++-- | Limitations for security.+--+-- @since 2.1.7+data Limit = Limit+ { limitRecordSize :: Maybe Int+ -- ^ Record size limit defined in RFC 8449.+ --+ -- If 'Nothing', the "record_size_limit" extension is not used.+ --+ -- In the case of 'Just': A client sends the "record_size_limit"+ -- extension with this value to the server. A server sends back+ -- this extension with its own value if a client sends the+ -- extension. When negotiated, both my limit and peer's limit are+ -- enabled for protected communication.+ --+ -- Default: Nothing+ , limitHandshakeFragment :: Int+ -- ^ The limit to accept the number of each handshake message.+ -- For instance, a nasty client may send many fragments of client+ -- certificate.+ --+ -- Default: 32+ }+ deriving (Eq, Show)++-- | Default value for 'Limit'.+defaultLimit :: Limit+defaultLimit =+ Limit+ { limitRecordSize = Nothing+ , limitHandshakeFragment = 32+ }
Network/TLS/PostHandshake.hs view
@@ -3,28 +3,29 @@ requestCertificateServer, postHandshakeAuthWith, postHandshakeAuthClientWith,- postHandshakeAuthServerWith, ) where import Network.TLS.Context.Internal-import Network.TLS.IO-import Network.TLS.Struct13- import Network.TLS.Handshake.Client import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server+import Network.TLS.IO+import Network.TLS.Struct13 --- | Post-handshake certificate request with TLS 1.3. Returns 'True' if the--- request was possible, i.e. if TLS 1.3 is used and the remote client supports--- post-handshake authentication.+----------------------------------------------------------------++-- | Post-handshake certificate request with TLS 1.3. Returns 'False'+-- if the request was impossible, i.e. the remote client supports+-- post-handshake authentication or the connection is established in+-- TLS 1.2. Returns 'True' if the client authentication succeeds. An+-- exception is thrown if the authentication fails. Server only. requestCertificate :: Context -> IO Bool requestCertificate ctx =- withWriteLock ctx $- checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx+ checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx --- Handle a post-handshake authentication flight with TLS 1.3. This is called--- automatically by 'recvData', in a context where the read lock is already--- taken.+-- | Handle a post-handshake authentication flight with TLS 1.3. This+-- is called automatically by 'recvData', in a context where the read+-- lock is already taken. Client only. postHandshakeAuthWith :: Context -> Handshake13 -> IO () postHandshakeAuthWith ctx hs = withWriteLock ctx $
Network/TLS/QUIC.hs view
@@ -68,12 +68,15 @@ defaultSupported, ) where +import Data.Default (def)+ import Network.TLS.Backend import Network.TLS.Context import Network.TLS.Context.Internal 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@@ -81,14 +84,12 @@ import Network.TLS.Handshake.State13 import Network.TLS.Imports import Network.TLS.KeySchedule (hkdfExpandLabel, hkdfExtract)-import Network.TLS.Parameters+import Network.TLS.Parameters hiding (defaultSupported) import Network.TLS.Record.Layer import Network.TLS.Record.State import Network.TLS.Struct import Network.TLS.Types -import Data.Default.Class- nullBackend :: Backend nullBackend = Backend@@ -115,7 +116,7 @@ { quicSend :: [(CryptLevel, ByteString)] -> IO () -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The -- content transiting on this API is the plaintext of the fragments and- -- QUIC responsability is to encrypt this payload with the key material+ -- QUIC responsibility is to encrypt this payload with the key material -- given for the specified level and an appropriate encryption scheme. -- -- The size of the fragments may exceed QUIC datagram limits so QUIC may@@ -170,10 +171,13 @@ tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ())- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks@@ -190,7 +194,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -200,10 +204,13 @@ tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams+ mylimref <- newRecordLimitRef Nothing+ peerlimref <- newRecordLimitRef Nothing let ctx1 = ctx0 { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync- , ctxFragmentSize = Nothing+ , ctxMyRecordLimit = mylimref+ , ctxPeerRecordLimit = peerlimref , ctxQUICMode = True } rl = newRecordLayer callbacks@@ -215,7 +222,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)@@ -246,9 +253,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] }
− Network/TLS/Receiving.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Receiving (- processPacket,- processPacket13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Handshake.State-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Util-import Network.TLS.Wire--processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet)-processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment-processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of- Left err -> return $ Left err- Right _ -> do- switchRxEncryption ctx- return $ Right ChangeCipherSpec-processPacket ctx (Record ProtocolType_Handshake ver fragment) = do- keyxchg <-- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)- usingState ctx $ do- let currentParams =- CurrentParams- { cParamsVersion = ver- , cParamsKeyXchgType = keyxchg- }- -- get back the optional continuation, and parse as many handshake record as possible.- mCont <- gets stHandshakeRecordCont- modify (\st -> st{stHandshakeRecordCont = Nothing})- hss <- parseMany currentParams mCont (fragmentGetBytes fragment)- return $ Handshake hss- where- parseMany currentParams mCont bs =- case fromMaybe decodeHandshakeRecord mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake currentParams ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake currentParams ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany currentParams Nothing left-processPacket _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")--switchRxEncryption :: Context -> IO ()-switchRxEncryption ctx =- usingHState ctx (gets hstPendingRxState) >>= \rx ->- modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx)--------------------------------------------------------------------processPacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)-processPacket13 _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right ChangeCipherSpec13-processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment-processPacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))-processPacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do- mCont <- gets stHandshakeRecordCont13- modify (\st -> st{stHandshakeRecordCont13 = Nothing})- hss <- parseMany mCont (fragmentGetBytes fragment)- return $ Handshake13 hss- where- parseMany mCont bs =- case fromMaybe decodeHandshakeRecord13 mCont bs of- GotError err -> throwError err- GotPartial cont ->- modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []- GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake13 ty content- GotSuccessRemaining (ty, content) left ->- case decodeHandshake13 ty content of- Left err -> throwError err- Right hh -> (hh :) <$> parseMany Nothing left-processPacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
Network/TLS/Record.hs view
@@ -15,12 +15,11 @@ rawToRecord, recordToHeader, Plaintext,- Compressed, Ciphertext, - -- * Engage and disengage from the record layer- engageRecord,- disengageRecord,+ -- * Encrypt and decrypt from the record layer+ encryptRecord,+ decryptRecord, -- * State tracking RecordM,@@ -31,7 +30,7 @@ setRecordIV, ) where -import Network.TLS.Record.Disengage-import Network.TLS.Record.Engage+import Network.TLS.Record.Decrypt+import Network.TLS.Record.Encrypt import Network.TLS.Record.State import Network.TLS.Record.Types
+ Network/TLS/Record/Decrypt.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE FlexibleContexts #-}++module Network.TLS.Record.Decrypt (+ decryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Crypto+import Network.TLS.ErrT+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Struct+import Network.TLS.Util+import Network.TLS.Wire++decryptRecord :: Record Ciphertext -> Int -> RecordM (Record Plaintext)+decryptRecord record@(Record ct ver fragment) lim = do+ st <- get+ case stCipher st of+ Nothing -> noDecryption+ _ -> do+ recOpts <- getRecordOptions+ let mver = recordVersion recOpts+ if recordTLS13 recOpts+ then decryptData13 mver (fragmentGetBytes fragment) st+ else onRecordFragment record $ fragmentUncipher $ \e ->+ decryptData mver record e st lim+ where+ noDecryption = onRecordFragment record $ fragmentUncipher $ checkPlainLimit lim+ decryptData13 mver e st = case ct of+ ProtocolType_AppData -> do+ inner <- decryptData mver record e st (lim + 1)+ case unInnerPlaintext inner of+ Left message -> throwError $ Error_Protocol message UnexpectedMessage+ Right (ct', d) -> return $ Record ct' ver $ fragmentPlaintext d+ ProtocolType_ChangeCipherSpec -> noDecryption+ ProtocolType_Alert -> noDecryption+ _ ->+ throwError $ Error_Protocol "illegal plain text" UnexpectedMessage++unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)+unInnerPlaintext inner =+ case B.unsnoc dc of+ Nothing -> Left $ unknownContentType13 (0 :: Word8)+ Just (bytes, c)+ | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->+ Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")+ | otherwise -> Right (ProtocolType c, bytes)+ where+ (dc, _pad) = B.spanEnd (== 0) inner+ nonEmptyContentTypes = [ProtocolType_Handshake, ProtocolType_Alert]+ unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c++getCipherData :: Record a -> CipherData -> RecordM ByteString+getCipherData (Record pt ver _) cdata = do+ -- check if the MAC is valid.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest new_hdr $ cipherDataContent cdata+ return (expected_digest == digest)++ -- check if the padding is filled with the correct pattern if it exists+ -- (before TLS10 this checks instead that the padding length is minimal)+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just (pad, _blksz) -> do+ let b = B.length pad - 1+ return $ B.replicate (B.length pad) (fromIntegral b) == pad++ unless (macValid &&! paddingValid) $+ throwError $+ Error_Protocol "bad record mac Stream/Block" BadRecordMac++ return $ cipherDataContent cdata++checkPlainLimit :: Int -> ByteString -> RecordM ByteString+checkPlainLimit lim plain+ | len > lim =+ throwError $+ Error_Protocol+ ( "plaintext exceeding record size limit: "+ ++ show len+ ++ " > "+ ++ show lim+ )+ RecordOverflow+ | otherwise = return plain+ where+ len = B.length plain++decryptData+ :: Version+ -> Record Ciphertext+ -> ByteString+ -> RecordState+ -> Int+ -> RecordM ByteString+decryptData ver record econtent tst lim =+ decryptOf (cstKey cst) >>= checkPlainLimit lim+ where+ cipher = fromJust $ stCipher tst+ bulk = cipherBulk cipher+ cst = stCryptState tst+ macSize = hashDigestSize $ cipherHash cipher+ blockSize = bulkBlockSize bulk+ econtentLen = B.length econtent++ sanityCheckError =+ throwError+ (Error_Packet "encrypted content too small for encryption parameters")++ decryptOf :: BulkState -> RecordM ByteString+ decryptOf (BulkStateBlock decryptF) = do+ let minContent = bulkIVSize bulk + max (macSize + 1) blockSize++ -- check if we have enough bytes to cover the minimum for this cipher+ when+ ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)+ sanityCheckError++ {- update IV -}+ (iv, econtent') <-+ get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)+ let (content', iv') = decryptF iv econtent'+ modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}}++ let paddinglength = fromIntegral (B.last content') + 1+ let contentlen = B.length content' - paddinglength - macSize+ (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)+ getCipherData+ record+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just (padding, blockSize)+ }+ decryptOf (BulkStateStream (BulkStream decryptF)) = do+ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < macSize) sanityCheckError++ let (content', bulkStream') = decryptF econtent+ {- update Ctx -}+ let contentlen = B.length content' - macSize+ (content, mac) <- get2i content' (contentlen, macSize)+ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}+ getCipherData+ record+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ decryptOf (BulkStateAEAD decryptF) = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cipherLen = econtentLen - authTagLen - nonceExpLen++ -- check if we have enough bytes to cover the minimum for this cipher+ when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError++ (enonce, econtent', authTag) <-+ get3o econtent (nonceExpLen, cipherLen, authTagLen)+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tst+ iv = cstIV (stCryptState tst)+ ivlen = B.length iv+ Header typ v _ = recordToHeader record+ hdrLen = if ver >= TLS13 then econtentLen else cipherLen+ hdr = Header typ v $ fromIntegral hdrLen+ ad+ | ver >= TLS13 = encodeHeader hdr+ | otherwise = B.concat [encodedSeq, encodeHeader hdr]+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce+ | nonceExpLen == 0 = BA.xor iv sqnc+ | otherwise = iv `B.append` enonce+ (content, authTag2) = decryptF nonce econtent' ad++ when (AuthTag (convert authTag) /= authTag2) $+ throwError $+ Error_Protocol "bad record mac on AEAD" BadRecordMac++ modify' incrRecordState+ return content+ decryptOf BulkStateUninitialized =+ throwError $ Error_Protocol "decrypt state uninitialized" InternalError++ -- handling of outer format can report errors with Error_Packet+ get3o s ls =+ maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls+ get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)++ -- all format errors related to decrypted content are reported+ -- externally as integrity failures, i.e. BadRecordMac+ get3i s ls =+ maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $+ partition3 s ls+ get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)
− Network/TLS/Record/Disengage.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Network.TLS.Record.Disengage (- disengageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B--import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Crypto-import Network.TLS.ErrT-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Struct-import Network.TLS.Util-import Network.TLS.Wire--disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext)-disengageRecord = decryptRecord >=> uncompressRecord--uncompressRecord :: Record Compressed -> RecordM (Record Plaintext)-uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes--decryptRecord :: Record Ciphertext -> RecordM (Record Compressed)-decryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- Nothing -> noDecryption- _ -> do- recOpts <- getRecordOptions- let mver = recordVersion recOpts- if recordTLS13 recOpts- then decryptData13 mver (fragmentGetBytes fragment) st- else onRecordFragment record $ fragmentUncipher $ \e ->- decryptData mver record e st- where- noDecryption = onRecordFragment record $ fragmentUncipher return- decryptData13 mver e st = case ct of- ProtocolType_AppData -> do- inner <- decryptData mver record e st- case unInnerPlaintext inner of- Left message -> throwError $ Error_Protocol message UnexpectedMessage- Right (ct', d) -> return $ Record ct' ver (fragmentCompressed d)- ProtocolType_ChangeCipherSpec -> noDecryption- ProtocolType_Alert -> noDecryption- _ ->- throwError $ Error_Protocol "illegal plain text" UnexpectedMessage--unInnerPlaintext :: ByteString -> Either String (ProtocolType, ByteString)-unInnerPlaintext inner =- case B.unsnoc dc of- Nothing -> Left $ unknownContentType13 (0 :: Word8)- Just (bytes, c)- | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes ->- Left ("empty " ++ show (ProtocolType c) ++ " record disallowed")- | otherwise -> Right (ProtocolType c, bytes)- where- (dc, _pad) = B.spanEnd (== 0) inner- nonEmptyContentTypes = [ProtocolType_Handshake, ProtocolType_Alert]- unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c--getCipherData :: Record a -> CipherData -> RecordM ByteString-getCipherData (Record pt ver _) cdata = do- -- check if the MAC is valid.- macValid <- case cipherDataMAC cdata of- Nothing -> return True- Just digest -> do- let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)- expected_digest <- makeDigest new_hdr $ cipherDataContent cdata- return (expected_digest == digest)-- -- check if the padding is filled with the correct pattern if it exists- -- (before TLS10 this checks instead that the padding length is minimal)- paddingValid <- case cipherDataPadding cdata of- Nothing -> return True- Just (pad, _blksz) -> do- let b = B.length pad - 1- return $ B.replicate (B.length pad) (fromIntegral b) == pad-- unless (macValid &&! paddingValid) $- throwError $- Error_Protocol "bad record mac Stream/Block" BadRecordMac-- return $ cipherDataContent cdata--decryptData- :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString-decryptData ver record econtent tst = decryptOf (cstKey cst)- where- cipher = fromJust $ stCipher tst- bulk = cipherBulk cipher- cst = stCryptState tst- macSize = hashDigestSize $ cipherHash cipher- blockSize = bulkBlockSize bulk- econtentLen = B.length econtent-- sanityCheckError =- throwError- (Error_Packet "encrypted content too small for encryption parameters")-- decryptOf :: BulkState -> RecordM ByteString- decryptOf (BulkStateBlock decryptF) = do- let minContent = bulkIVSize bulk + max (macSize + 1) blockSize-- -- check if we have enough bytes to cover the minimum for this cipher- when- ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent)- sanityCheckError-- {- update IV -}- (iv, econtent') <-- get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)- let (content', iv') = decryptF iv econtent'- modify $ \txs -> txs{stCryptState = cst{cstIV = iv'}}-- let paddinglength = fromIntegral (B.last content') + 1- let contentlen = B.length content' - paddinglength - macSize- (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)- getCipherData- record- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just (padding, blockSize)- }- decryptOf (BulkStateStream (BulkStream decryptF)) = do- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < macSize) sanityCheckError-- let (content', bulkStream') = decryptF econtent- {- update Ctx -}- let contentlen = B.length content' - macSize- (content, mac) <- get2i content' (contentlen, macSize)- modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}- getCipherData- record- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- decryptOf (BulkStateAEAD decryptF) = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cipherLen = econtentLen - authTagLen - nonceExpLen-- -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError-- (enonce, econtent', authTag) <-- get3o econtent (nonceExpLen, cipherLen, authTagLen)- let encodedSeq = encodeWord64 $ msSequence $ stMacState tst- iv = cstIV (stCryptState tst)- ivlen = B.length iv- Header typ v _ = recordToHeader record- hdrLen = if ver >= TLS13 then econtentLen else cipherLen- hdr = Header typ v $ fromIntegral hdrLen- ad- | ver >= TLS13 = encodeHeader hdr- | otherwise = B.concat [encodedSeq, encodeHeader hdr]- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce- | nonceExpLen == 0 = B.xor iv sqnc- | otherwise = iv `B.append` enonce- (content, authTag2) = decryptF nonce econtent' ad-- when (AuthTag (B.convert authTag) /= authTag2) $- throwError $- Error_Protocol "bad record mac on AEAD" BadRecordMac-- modify incrRecordState- return content- decryptOf BulkStateUninitialized =- throwError $ Error_Protocol "decrypt state uninitialized" InternalError-- -- handling of outer format can report errors with Error_Packet- get3o s ls =- maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls- get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)-- -- all format errors related to decrypted content are reported- -- externally as integrity failures, i.e. BadRecordMac- get3i s ls =- maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $- partition3 s ls- get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)
+ Network/TLS/Record/Encrypt.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- Engage a record into the Record layer.+-- The record is compressed, added some integrity field, then encrypted.+--+-- Starting with TLS v1.3, only the "null" compression method is negotiated in+-- the handshake, so the compression step will be a no-op. Integrity and+-- encryption are performed using an AEAD cipher only.+module Network.TLS.Record.Encrypt (+ encryptRecord,+) where++import Control.Monad.State.Strict+import Crypto.Cipher.Types (AuthTag (..))+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record.State+import Network.TLS.Record.Types+import Network.TLS.Wire++-- when Tx Encrypted is set, we pass the data through encryptContent, otherwise+-- we just return the compress payload directly as the ciphered one+--+encryptRecord :: Record Plaintext -> RecordM (Record Ciphertext)+encryptRecord record@(Record ct ver fragment) = do+ st <- get+ case stCipher st of+ Nothing -> noEncryption+ _ -> do+ recOpts <- getRecordOptions+ if recordTLS13 recOpts+ then encryptContent13+ else onRecordFragment record $ fragmentCipher (encryptContent False record)+ where+ noEncryption = onRecordFragment record $ fragmentCipher return+ encryptContent13+ | ct == ProtocolType_ChangeCipherSpec = noEncryption+ | otherwise = do+ let bytes = fragmentGetBytes fragment+ fragment' = fragmentPlaintext $ innerPlaintext ct bytes+ record' = Record ProtocolType_AppData ver fragment'+ onRecordFragment record' $ fragmentCipher (encryptContent True record')++innerPlaintext :: ProtocolType -> ByteString -> ByteString+innerPlaintext (ProtocolType c) bytes = runPut $ do+ putBytes bytes+ putWord8 c -- non zero!+ -- fixme: zeros padding++encryptContent :: Bool -> Record Plaintext -> ByteString -> RecordM ByteString+encryptContent tls13 record content = do+ cst <- getCryptState+ bulk <- getBulk+ case cstKey cst of+ BulkStateBlock encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptBlock encryptF content' bulk+ BulkStateStream encryptF -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptStream encryptF content'+ BulkStateAEAD encryptF ->+ encryptAead tls13 bulk encryptF content record+ BulkStateUninitialized ->+ return content++encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString+encryptBlock encryptF content bulk = do+ cst <- getCryptState+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding =+ if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize)+ in let padbyte' = if padbyte == 0 then blockSize else padbyte+ in B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else B.empty++ let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]++ return $ B.concat [cstIV cst, e]++encryptStream :: BulkStream -> ByteString -> RecordM ByteString+encryptStream (BulkStream encryptF) content = do+ cst <- getCryptState+ let (!e, !newBulkStream) = encryptF content+ modify' $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}+ return e++encryptAead+ :: Bool+ -> Bulk+ -> BulkAEAD+ -> ByteString+ -> Record Plaintext+ -> RecordM ByteString+encryptAead tls13 bulk encryptF content record = do+ let authTagLen = bulkAuthTagLen bulk+ nonceExpLen = bulkExplicitIV bulk+ cst <- getCryptState+ encodedSeq <- encodeWord64 <$> getMacSequence++ let iv = cstIV cst+ ivlen = B.length iv+ Header typ v plainLen = recordToHeader record+ hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen+ hdr = Header typ v hdrLen+ ad+ | tls13 = encodeHeader hdr+ | otherwise = B.concat [encodedSeq, encodeHeader hdr]+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce+ | nonceExpLen == 0 = BA.xor iv sqnc+ | otherwise = B.concat [iv, encodedSeq]+ (e, AuthTag authtag) = encryptF nonce content ad+ econtent+ | nonceExpLen == 0 = e `B.append` convert authtag+ | otherwise = B.concat [encodedSeq, e, convert authtag]+ modify' incrRecordState+ return econtent++getCryptState :: RecordM CryptState+getCryptState = stCryptState <$> get
− Network/TLS/Record/Engage.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- |--- Engage a record into the Record layer.--- The record is compressed, added some integrity field, then encrypted.------ Starting with TLS v1.3, only the "null" compression method is negotiated in--- the handshake, so the compression step will be a no-op. Integrity and--- encryption are performed using an AEAD cipher only.-module Network.TLS.Record.Engage (- engageRecord,-) where--import Control.Monad.State.Strict-import Crypto.Cipher.Types (AuthTag (..))--import qualified Data.ByteArray as B (convert, xor)-import qualified Data.ByteString as B-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record.State-import Network.TLS.Record.Types-import Network.TLS.Wire--engageRecord :: Record Plaintext -> RecordM (Record Ciphertext)-engageRecord = compressRecord >=> encryptRecord--compressRecord :: Record Plaintext -> RecordM (Record Compressed)-compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes---- when Tx Encrypted is set, we pass the data through encryptContent, otherwise--- we just return the compress payload directly as the ciphered one----encryptRecord :: Record Compressed -> RecordM (Record Ciphertext)-encryptRecord record@(Record ct ver fragment) = do- st <- get- case stCipher st of- Nothing -> noEncryption- _ -> do- recOpts <- getRecordOptions- if recordTLS13 recOpts- then encryptContent13- else onRecordFragment record $ fragmentCipher (encryptContent False record)- where- noEncryption = onRecordFragment record $ fragmentCipher return- encryptContent13- | ct == ProtocolType_ChangeCipherSpec = noEncryption- | otherwise = do- let bytes = fragmentGetBytes fragment- fragment' = fragmentCompressed $ innerPlaintext ct bytes- record' = Record ProtocolType_AppData ver fragment'- onRecordFragment record' $ fragmentCipher (encryptContent True record')--innerPlaintext :: ProtocolType -> ByteString -> ByteString-innerPlaintext (ProtocolType c) bytes = runPut $ do- putBytes bytes- putWord8 c -- non zero!- -- fixme: zeros padding--encryptContent :: Bool -> Record Compressed -> ByteString -> RecordM ByteString-encryptContent tls13 record content = do- cst <- getCryptState- bulk <- getBulk- case cstKey cst of- BulkStateBlock encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptBlock encryptF content' bulk- BulkStateStream encryptF -> do- digest <- makeDigest (recordToHeader record) content- let content' = B.concat [content, digest]- encryptStream encryptF content'- BulkStateAEAD encryptF ->- encryptAead tls13 bulk encryptF content record- BulkStateUninitialized ->- return content--encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString-encryptBlock encryptF content bulk = do- cst <- getCryptState- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding =- if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize)- in let padbyte' = if padbyte == 0 then blockSize else padbyte- in B.replicate padbyte' (fromIntegral (padbyte' - 1))- else B.empty-- let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding]-- return $ B.concat [cstIV cst, e]--encryptStream :: BulkStream -> ByteString -> RecordM ByteString-encryptStream (BulkStream encryptF) content = do- cst <- getCryptState- let (!e, !newBulkStream) = encryptF content- modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}}- return e--encryptAead- :: Bool- -> Bulk- -> BulkAEAD- -> ByteString- -> Record Compressed- -> RecordM ByteString-encryptAead tls13 bulk encryptF content record = do- let authTagLen = bulkAuthTagLen bulk- nonceExpLen = bulkExplicitIV bulk- cst <- getCryptState- encodedSeq <- encodeWord64 <$> getMacSequence-- let iv = cstIV cst- ivlen = B.length iv- Header typ v plainLen = recordToHeader record- hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen- hdr = Header typ v hdrLen- ad- | tls13 = encodeHeader hdr- | otherwise = B.concat [encodedSeq, encodeHeader hdr]- sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq- nonce- | nonceExpLen == 0 = B.xor iv sqnc- | otherwise = B.concat [iv, encodedSeq]- (e, AuthTag authtag) = encryptF nonce content ad- econtent- | nonceExpLen == 0 = e `B.append` B.convert authtag- | otherwise = B.concat [encodedSeq, e, B.convert authtag]- modify incrRecordState- return econtent--getCryptState :: RecordM CryptState-getCryptState = stCryptState <$> get
Network/TLS/Record/Layer.hs view
@@ -18,10 +18,10 @@ -> RecordLayer [(ann, ByteString)] newTransparentRecordLayer get send recv = RecordLayer- { recordEncode = transparentEncodeRecord get+ { recordEncode12 = transparentEncodeRecord get , recordEncode13 = transparentEncodeRecord get , recordSendBytes = transparentSendBytes send- , recordRecv = \ctx _ -> transparentRecvRecord recv ctx+ , recordRecv12 = transparentRecvRecord recv , recordRecv13 = transparentRecvRecord recv }
− Network/TLS/Record/Reading.hs
@@ -1,103 +0,0 @@--- | TLS record layer in Rx direction-module Network.TLS.Record.Reading (- recvRecord,- recvRecord13,-) where--import qualified Data.ByteString as B--import Network.TLS.Context.Internal-import Network.TLS.ErrT-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--------------------------------------------------------------------exceeds :: Integral ty => Context -> Int -> ty -> Bool-exceeds ctx overhead actual =- case ctxFragmentSize ctx of- Nothing -> False- Just sz -> fromIntegral actual > sz + overhead--getRecord- :: Context- -> Int- -> Header- -> ByteString- -> IO (Either TLSError (Record Plaintext))-getRecord ctx appDataOverhead header@(Header pt _ _) content = do- withLog ctx $ \logging -> loggingIORecv logging header content- runRxRecordState ctx $ do- r <- decodeRecordM header content- let Record _ _ fragment = r- when (exceeds ctx overhead $ B.length (fragmentGetBytes fragment)) $- throwError contentSizeExceeded- return r- where- overhead = if pt == ProtocolType_AppData then appDataOverhead else 0--decodeRecordM :: Header -> ByteString -> RecordM (Record Plaintext)-decodeRecordM header content = disengageRecord erecord- where- erecord = rawToRecord header (fragmentCiphertext content)--contentSizeExceeded :: TLSError-contentSizeExceeded = Error_Protocol "record content exceeding maximum size" RecordOverflow---------------------------------------------------------------------- | recvRecord receive a full TLS record (header + data), from the other side.------ The record is disengaged from the record layer-recvRecord- :: Context- -- ^ TLS context- -> Int- -- ^ number of AppData bytes to accept above normal maximum size- -> IO (Either TLSError (Record Plaintext))-recvRecord ctx appDataOverhead =- readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength-- recvLength header@(Header _ _ readlen)- | exceeds ctx 2048 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx appDataOverhead header)--recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))-recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)- where- recvLengthE = either (return . Left) recvLength- recvLength header@(Header _ _ readlen)- | exceeds ctx 256 readlen = return $ Left maximumSizeExceeded- | otherwise =- readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx 0 header)--maximumSizeExceeded :: TLSError-maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow--------------------------------------------------------------------readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)-readExactBytes ctx sz = do- hdrbs <- contextRecv ctx sz- if B.length hdrbs == sz- then return $ Right hdrbs- else do- setEOF ctx- return . Left $- if B.null hdrbs- then Error_EOF- else- Error_Packet- ( "partial packet: expecting "- ++ show sz- ++ " bytes, got: "- ++ show (B.length hdrbs)- )
+ Network/TLS/Record/Recv.hs view
@@ -0,0 +1,112 @@+-- | TLS record layer in Rx direction+module Network.TLS.Record.Recv (+ recvRecord12,+ recvRecord13,+) where++import qualified Data.ByteString as B++import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct+import Network.TLS.Types++----------------------------------------------------------------++getMyPlainLimit :: Context -> IO Int+getMyPlainLimit ctx = do+ msiz <- getMyRecordLimit ctx+ return $ case msiz of+ Nothing -> defaultRecordSizeLimit+ Just siz -> siz++getRecord+ :: Context+ -> Header+ -> ByteString+ -> IO (Either TLSError (Record Plaintext))+getRecord ctx header content = do+ withLog ctx $ \logging -> loggingIORecv logging header content+ lim <- getMyPlainLimit ctx+ runRxRecordState ctx $ do+ let erecord = rawToRecord header $ fragmentCiphertext content+ decryptRecord erecord lim++----------------------------------------------------------------++exceedsTLSCiphertext :: Int -> Word16 -> Bool+exceedsTLSCiphertext overhead actual =+ -- In TLS 1.3, overhead is included one more byte for content type.+ fromIntegral actual > defaultRecordSizeLimit + overhead++-- | recvRecord receive a full TLS record (header + data), from the other side.+--+-- The record is disengaged from the record layer+recvRecord12+ :: Context+ -- ^ TLS context+ -> IO (Either TLSError (Record Plaintext))+recvRecord12 ctx =+ readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ where+ recvLengthE = either (return . Left) recvLength++ recvLength header@(Header _ _ readlen) = do+ -- RFC 5246 Section 7.2.2+ -- A TLSCiphertext record was received that had a length more+ -- than 2^14+2048 bytes, or a record decrypted to a+ -- TLSCompressed record with more than 2^14+1024 bytes. This+ -- message is always fatal and should never be observed in+ -- communication between proper implementations (except when+ -- messages were corrupted in the network).+ if exceedsTLSCiphertext 2048 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))+recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ where+ recvLengthE = either (return . Left) recvLength+ recvLength header@(Header _ _ readlen) = do+ -- RFC 8446 Section 5.2:+ -- An AEAD algorithm used in TLS 1.3 MUST NOT produce an+ -- expansion greater than 255 octets. An endpoint that+ -- receives a record from its peer with TLSCiphertext.length+ -- larger than 2^14 + 256 octets MUST terminate the connection+ -- with a "record_overflow" alert. This limit is derived from+ -- the maximum TLSInnerPlaintext length of 2^14 octets + 1+ -- octet for ContentType + the maximum AEAD expansion of 255+ -- octets.+ if exceedsTLSCiphertext 256 readlen+ then return $ Left maximumSizeExceeded+ else+ readExactBytes ctx (fromIntegral readlen)+ >>= either (return . Left) (getRecord ctx header)++maximumSizeExceeded :: TLSError+maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow++----------------------------------------------------------------++readExactBytes :: Context -> Int -> IO (Either TLSError ByteString)+readExactBytes ctx sz = do+ hdrbs <- contextRecv ctx sz+ if B.length hdrbs == sz+ then return $ Right hdrbs+ else do+ setEOF ctx+ return . Left $+ if B.null hdrbs+ then Error_EOF+ else+ Error_Packet+ ( "partial packet: expecting "+ ++ show sz+ ++ " bytes, got: "+ ++ show (B.length hdrbs)+ )
+ Network/TLS/Record/Send.hs view
@@ -0,0 +1,61 @@+-- | TLS record layer in Tx direction+module Network.TLS.Record.Send (+ encodeRecord12,+ encodeRecord13,+ sendBytes,+) where++import Control.Concurrent.MVar+import Control.Monad.State.Strict+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Context.Internal+import Network.TLS.Hooks+import Network.TLS.Imports+import Network.TLS.Packet+import Network.TLS.Record+import Network.TLS.Struct++encodeRecordM :: Record Plaintext -> RecordM ByteString+encodeRecordM record = do+ erecord <- encryptRecord record+ let (hdr, content) = recordToRaw erecord+ return $ B.concat [encodeHeader hdr, content]++----------------------------------------------------------------++encodeRecord12 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord12 ctx = prepareRecord12 ctx . encodeRecordM++-- before TLS 1.1, the block cipher IV is made of the residual of the previous block,+-- so we use cstIV as is, however in other case we generate an explicit IV+prepareRecord12 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord12 ctx f = do+ txState <- readMVar $ ctxTxRecordState ctx+ let sz = case stCipher txState of+ Nothing -> 0+ Just cipher ->+ if hasRecordIV $ bulkF $ cipherBulk cipher+ then bulkIVSize $ cipherBulk cipher+ else 0 -- to not generate IV+ if sz > 0+ then do+ newIV <- getStateRNG ctx sz+ runTxRecordState ctx (modify' (setRecordIV newIV) >> f)+ else runTxRecordState ctx f++----------------------------------------------------------------++encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)+encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM++prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord13 = runTxRecordState++----------------------------------------------------------------++sendBytes :: Context -> ByteString -> IO ()+sendBytes ctx dataToSend = do+ withLog ctx $ \logging -> loggingIOSent logging dataToSend+ contextSend ctx dataToSend
Network/TLS/Record/State.hs view
@@ -22,6 +22,7 @@ ) where import Control.Monad.State.Strict+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher@@ -36,10 +37,10 @@ data CryptState = CryptState { cstKey :: BulkState- , cstIV :: ByteString+ , cstIV :: IV , -- In TLS 1.2 or earlier, this holds mac secret. -- In TLS 1.3, this holds application traffic secret N.- cstMacSecret :: ByteString+ cstMacSecret :: Secret } deriving (Show) @@ -130,7 +131,7 @@ { stCipher = Nothing , stCompression = nullCompression , stCryptLevel = CryptInitial- , stCryptState = CryptState BulkStateUninitialized B.empty B.empty+ , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty , stMacState = MacState 0 } @@ -153,7 +154,7 @@ :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest _ver tstate hdr content = (digest, incrRecordState tstate) where- digest = macF (cstMacSecret cst) msg+ digest = BA.convert $ macF (cstMacSecret cst) msg cst = stCryptState tstate cipher = fromJust $ stCipher tstate hashA = cipherHash cipher
Network/TLS/Record/Types.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE EmptyDataDecls #-} -- | The Record Protocol takes messages to be transmitted, fragments--- the data into manageable blocks, optionally compresses the data,--- applies a MAC, encrypts, and transmits the result. Received data--- is decrypted, verified, decompressed, reassembled, and then--- delivered to higher-level clients.+-- the data into manageable blocks. applies a MAC, encrypts, and+-- transmits the result. Received data is decrypted, verified,+-- reassembled, and then delivered to higher-level clients. module Network.TLS.Record.Types ( Header (..), ProtocolType (..),@@ -17,18 +16,14 @@ Fragment, fragmentGetBytes, fragmentPlaintext,- fragmentCompressed, fragmentCiphertext, Plaintext,- Compressed, Ciphertext, -- * manipulate record onRecordFragment,- fragmentCompress, fragmentCipher, fragmentUncipher,- fragmentUncompress, -- * serialize record rawToRecord,@@ -37,6 +32,7 @@ ) where import qualified Data.ByteString as B+ import Network.TLS.Imports import Network.TLS.Record.State import Network.TLS.Struct@@ -48,15 +44,11 @@ deriving (Show, Eq) data Plaintext-data Compressed data Ciphertext fragmentPlaintext :: ByteString -> Fragment Plaintext fragmentPlaintext bytes = Fragment bytes -fragmentCompressed :: ByteString -> Fragment Compressed-fragmentCompressed bytes = Fragment bytes- fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes @@ -68,33 +60,19 @@ :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) fragmentMap f (Fragment b) = Fragment <$> f b --- | turn a plaintext record into a compressed record using the compression function supplied-fragmentCompress- :: (ByteString -> RecordM ByteString)- -> Fragment Plaintext- -> RecordM (Fragment Compressed)-fragmentCompress f = fragmentMap f- -- | turn a compressed record into a ciphertext record using the cipher function supplied fragmentCipher :: (ByteString -> RecordM ByteString)- -> Fragment Compressed+ -> Fragment Plaintext -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f --- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+-- | turn a ciphertext fragment into a plaintext fragment using the cipher function supplied fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext- -> RecordM (Fragment Compressed)-fragmentUncipher f = fragmentMap f---- | turn a compressed fragment into a plaintext fragment using the decompression function supplied-fragmentUncompress- :: (ByteString -> RecordM ByteString)- -> Fragment Compressed -> RecordM (Fragment Plaintext)-fragmentUncompress f = fragmentMap f+fragmentUncipher f = fragmentMap f -- | turn a record into an header and bytes recordToRaw :: Record a -> (Header, ByteString)
− Network/TLS/Record/Writing.hs
@@ -1,59 +0,0 @@--- | TLS record layer in Tx direction-module Network.TLS.Record.Writing (- encodeRecord,- encodeRecord13,- sendBytes,-) where--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Hooks-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Record-import Network.TLS.Struct--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B--encodeRecord :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord ctx = prepareRecord ctx . encodeRecordM---- before TLS 1.1, the block cipher IV is made of the residual of the previous block,--- so we use cstIV as is, however in other case we generate an explicit IV-prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord ctx f = do- txState <- readMVar $ ctxTxRecordState ctx- let sz = case stCipher txState of- Nothing -> 0- Just cipher ->- if hasRecordIV $ bulkF $ cipherBulk cipher- then bulkIVSize $ cipherBulk cipher- else 0 -- to not generate IV- if sz > 0- then do- newIV <- getStateRNG ctx sz- runTxRecordState ctx (modify (setRecordIV newIV) >> f)- else runTxRecordState ctx f--encodeRecordM :: Record Plaintext -> RecordM ByteString-encodeRecordM record = do- erecord <- engageRecord record- let (hdr, content) = recordToRaw erecord- return $ B.concat [encodeHeader hdr, content]--------------------------------------------------------------------encodeRecord13 :: Context -> Record Plaintext -> IO (Either TLSError ByteString)-encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM--prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a)-prepareRecord13 = runTxRecordState--------------------------------------------------------------------sendBytes :: Context -> ByteString -> IO ()-sendBytes ctx dataToSend = do- withLog ctx $ \logging -> loggingIOSent logging dataToSend- contextSend ctx dataToSend
− Network/TLS/Sending.hs
@@ -1,124 +0,0 @@-module Network.TLS.Sending (- encodePacket12,- encodePacket13,- updateHandshake12,- updateHandshake13,-) where--import Control.Concurrent.MVar-import Control.Monad.State.Strict-import qualified Data.ByteString as B-import Data.IORef--import Network.TLS.Cipher-import Network.TLS.Context.Internal-import Network.TLS.Handshake.Random-import Network.TLS.Handshake.State-import Network.TLS.Handshake.State13-import Network.TLS.Imports-import Network.TLS.Packet-import Network.TLS.Packet13-import Network.TLS.Parameters-import Network.TLS.Record-import Network.TLS.State-import Network.TLS.Struct-import Network.TLS.Struct13-import Network.TLS.Types (Role (..))-import Network.TLS.Util---- | encodePacket transform a packet into marshalled data related to current state--- and updating state on the go-encodePacket12- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet- -> IO (Either TLSError bytes)-encodePacket12 ctx recordLayer pkt = do- (ver, _) <- decideRecordVersion ctx- let pt = packetType pkt- mkRecord bs = Record pt ver (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments12 ctx len pkt- bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer ctx)- when (pkt == ChangeCipherSpec) $ switchTxEncryption ctx- return bs---- Decompose handshake packets into fragments of the specified length. AppData--- packets are not fragmented here but by callers of sendPacket, so that the--- empty-packet countermeasure may be applied to each fragment independently.-packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments12 ctx len (Handshake hss) =- getChunks len . B.concat <$> mapM (updateHandshake12 ctx) hss-packetToFragments12 _ _ (Alert a) = return [encodeAlerts a]-packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec]-packetToFragments12 _ _ (AppData x) = return [x]--switchTxEncryption :: Context -> IO ()-switchTxEncryption ctx = do- tx <- usingHState ctx (fromJust <$> gets hstPendingTxState)- (ver, role) <- usingState_ ctx $ do- v <- getVersion- r <- getRole- return (v, r)- liftIO $ modifyMVar_ (ctxTxRecordState ctx) (\_ -> return tx)- -- set empty packet counter measure if condition are met- when- ( ver <= TLS10- && role == ClientRole- && isCBC tx- && supportedEmptyPacket (ctxSupported ctx)- )- $ liftIO- $ writeIORef (ctxNeedEmptyPacket ctx) True- where- isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx)--updateHandshake12 :: Context -> Handshake -> IO ByteString-updateHandshake12 ctx hs = do- usingHState ctx $ do- when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded- when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded- return encoded- where- encoded = encodeHandshake hs--------------------------------------------------------------------encodePacket13- :: Monoid bytes- => Context- -> RecordLayer bytes- -> Packet13- -> IO (Either TLSError bytes)-encodePacket13 ctx recordLayer pkt = do- let pt = contentType pkt- mkRecord bs = Record pt TLS12 (fragmentPlaintext bs)- len = ctxFragmentSize ctx- records <- map mkRecord <$> packetToFragments13 ctx len pkt- fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)--packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]-packetToFragments13 ctx len (Handshake13 hss) =- getChunks len . B.concat <$> mapM (updateHandshake13 ctx) hss-packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a]-packetToFragments13 _ _ (AppData13 x) = return [x]-packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec]--updateHandshake13 :: Context -> Handshake13 -> IO ByteString-updateHandshake13 ctx hs- | isIgnored hs = return encoded- | otherwise = usingHState ctx $ do- when (isHRR hs) wrapAsMessageHash13- updateHandshakeDigest encoded- addHandshakeMessage encoded- return encoded- where- encoded = encodeHandshake13 hs-- isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand- isHRR _ = False-- isIgnored NewSessionTicket13{} = True- isIgnored KeyUpdate13{} = True- isIgnored _ = False
Network/TLS/Session.hs view
@@ -5,18 +5,20 @@ import Network.TLS.Types --- | A session manager+-- | A session manager.+-- In the server side, all fields are used.+-- In the client side, only 'sessionEstablish' is used. data SessionManager = SessionManager { sessionResume :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used on TLS 1.2\/1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. , sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used for 0RTT on TLS 1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'.- , sessionEstablish :: SessionID -> SessionData -> IO (Maybe Ticket)- -- ^ Used TLS 1.2\/1.3 servers\/clients to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket'. In the client side, 'Nothing' should be returned. For clients, only this field should be set with 'noSessionManager'.- , sessionInvalidate :: SessionID -> IO ()- -- ^ Used TLS 1.2\/1.3 servers to delete 'SessionData' with 'SessionID' if @sessionUseTicket@ is 'True'.+ , sessionEstablish :: SessionIDorTicket -> SessionData -> IO (Maybe Ticket)+ -- ^ Used on TLS 1.2\/1.3 servers to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket' ignoring 'SessionID'. Used on TLS 1.2\/1.3 clients to store 'SessionData' with 'SessionIDorTicket' and then return 'Nothing'. For clients, only this field should be set with 'noSessionManager'.+ , sessionInvalidate :: SessionIDorTicket -> IO ()+ -- ^ Used TLS 1.2 servers to delete 'SessionData' with 'SessionID' on errors. , sessionUseTicket :: Bool- -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that TLS 1.3 servers always use session tickets.+ -- ^ Used on TLS 1.2 servers to decide to use 'SessionID' or 'Ticket'. Note that 'SessionID' and 'Ticket' are integrated as identity in TLS 1.3. } -- | The session manager to do nothing.
Network/TLS/State.hs view
@@ -37,6 +37,7 @@ setClientEcPointFormatSuggest, getClientEcPointFormatSuggest, setClientSNI,+ clearClientSNI, getClientSNI, getClientCertificateChain, setClientCertificateChain,@@ -44,10 +45,13 @@ setServerCertificateChain, setSession, getSession,- isSessionResuming, getRole,- setExporterSecret,- getExporterSecret,+ --+ setTLS12SessionResuming,+ getTLS12SessionResuming,+ --+ setTLS13ExporterSecret,+ getTLS13ExporterSecret, setTLS13KeyShare, getTLS13KeyShare, setTLS13PreSharedKey,@@ -56,8 +60,8 @@ getTLS13HRR, setTLS13Cookie, getTLS13Cookie,- setClientSupportsPHA,- getClientSupportsPHA,+ setTLS13ClientSupportsPHA,+ getTLS13ClientSupportsPHA, setTLS12SessionTicket, getTLS12SessionTicket, @@ -68,19 +72,18 @@ import Control.Monad.State.Strict import Crypto.Random-import qualified Data.ByteString as B import Data.X509 (CertificateChain)+ import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct-import Network.TLS.Types (HostName, Role (..), Ticket)+import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState { stSession :: Session- , stSessionResuming :: Bool , -- RFC 5746, Renegotiation Indication Extension -- RFC 5929, Channel Bindings for TLS, "tls-unique" stSecureRenegotiation :: Bool@@ -89,24 +92,29 @@ , -- RFC 5929, Channel Bindings for TLS, "tls-server-end-point" stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301- , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString))- , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol- , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString))- , stClientALPNSuggest :: Maybe [B.ByteString]+ , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol+ , stHandshakeRecordCont12+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+ , stHandshakeRecordCont13+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+ , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stClientSNI :: Maybe HostName , stRandomGen :: StateRNG- , stVersion :: Maybe Version , stClientContext :: Role- , stTLS13KeyShare :: Maybe KeyShare+ , stVersion :: Maybe Version+ , --+ stTLS12SessionResuming :: Bool+ , stTLS12SessionTicket :: Maybe Ticket+ , --+ stTLS13KeyShare :: Maybe KeyShare , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie- , stExporterSecret :: Maybe ByteString -- TLS 1.3- , stClientSupportsPHA :: Bool -- Post-Handshake Authentication (TLS 1.3)- , stTLS12SessionTicket :: Maybe Ticket+ , stTLS13ExporterSecret :: Maybe Secret+ , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } newtype TLSSt a = TLSSt {runTLSSt :: ErrT TLSError (State TLSState) a}@@ -124,45 +132,45 @@ newTLSState rng clientContext = TLSState { stSession = Session Nothing- , stSessionResuming = False , stSecureRenegotiation = False , stClientVerifyData = Nothing , stServerVerifyData = Nothing , stServerCertificateChain = Nothing , stExtensionALPN = False- , stHandshakeRecordCont = Nothing- , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing+ , stHandshakeRecordCont12 = (Nothing, [])+ , stHandshakeRecordCont13 = (Nothing, []) , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stClientSNI = Nothing , stRandomGen = rng- , stVersion = Nothing , stClientContext = clientContext+ , stVersion = Nothing+ , stTLS12SessionResuming = False+ , stTLS12SessionTicket = Nothing , stTLS13KeyShare = Nothing , stTLS13PreSharedKey = Nothing , stTLS13HRR = False , stTLS13Cookie = Nothing- , stExporterSecret = Nothing- , stClientSupportsPHA = False- , stTLS12SessionTicket = Nothing+ , stTLS13ExporterSecret = Nothing+ , stTLS13ClientSupportsPHA = False } setVerifyDataForSend :: VerifyData -> TLSSt () setVerifyDataForSend bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stClientVerifyData = Just bs})- ServerRole -> modify (\st -> st{stServerVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stClientVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stServerVerifyData = Just bs}) setVerifyDataForRecv :: VerifyData -> TLSSt () setVerifyDataForRecv bs = do role <- getRole case role of- ClientRole -> modify (\st -> st{stServerVerifyData = Just bs})- ServerRole -> modify (\st -> st{stClientVerifyData = Just bs})+ ClientRole -> modify' (\st -> st{stServerVerifyData = Just bs})+ ServerRole -> modify' (\st -> st{stClientVerifyData = Just bs}) finishedHandshakeTypeMaterial :: HandshakeType -> Bool finishedHandshakeTypeMaterial HandshakeType_ClientHello = True@@ -197,20 +205,23 @@ certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake -setSession :: Session -> Bool -> TLSSt ()-setSession session resuming = modify (\st -> st{stSession = session, stSessionResuming = resuming})+setSession :: Session -> TLSSt ()+setSession session = modify' (\st -> st{stSession = session}) getSession :: TLSSt Session getSession = gets stSession -isSessionResuming :: TLSSt Bool-isSessionResuming = gets stSessionResuming+setTLS12SessionResuming :: Bool -> TLSSt ()+setTLS12SessionResuming b = modify' (\st -> st{stTLS12SessionResuming = b}) +getTLS12SessionResuming :: TLSSt Bool+getTLS12SessionResuming = gets stTLS12SessionResuming+ setVersion :: Version -> TLSSt ()-setVersion ver = modify (\st -> st{stVersion = Just ver})+setVersion ver = modify' (\st -> st{stVersion = Just ver}) setVersionIfUnset :: Version -> TLSSt ()-setVersionIfUnset ver = modify maybeSet+setVersionIfUnset ver = modify' maybeSet where maybeSet st = case stVersion st of Nothing -> st{stVersion = Just ver}@@ -225,79 +236,86 @@ getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt ()-setSecureRenegotiation b = modify (\st -> st{stSecureRenegotiation = b})+setSecureRenegotiation b = modify' (\st -> st{stSecureRenegotiation = b}) getSecureRenegotiation :: TLSSt Bool getSecureRenegotiation = gets stSecureRenegotiation setExtensionALPN :: Bool -> TLSSt ()-setExtensionALPN b = modify (\st -> st{stExtensionALPN = b})+setExtensionALPN b = modify' (\st -> st{stExtensionALPN = b}) getExtensionALPN :: TLSSt Bool getExtensionALPN = gets stExtensionALPN -setNegotiatedProtocol :: B.ByteString -> TLSSt ()-setNegotiatedProtocol s = modify (\st -> st{stNegotiatedProtocol = Just s})+setNegotiatedProtocol :: ByteString -> TLSSt ()+setNegotiatedProtocol s = modify' (\st -> st{stNegotiatedProtocol = Just s}) -getNegotiatedProtocol :: TLSSt (Maybe B.ByteString)+getNegotiatedProtocol :: TLSSt (Maybe ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol -setClientALPNSuggest :: [B.ByteString] -> TLSSt ()-setClientALPNSuggest ps = modify (\st -> st{stClientALPNSuggest = Just ps})+setClientALPNSuggest :: [ByteString] -> TLSSt ()+setClientALPNSuggest ps = modify' (\st -> st{stClientALPNSuggest = Just ps}) -getClientALPNSuggest :: TLSSt (Maybe [B.ByteString])+getClientALPNSuggest :: TLSSt (Maybe [ByteString]) getClientALPNSuggest = gets stClientALPNSuggest setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt ()-setClientEcPointFormatSuggest epf = modify (\st -> st{stClientEcPointFormatSuggest = Just epf})+setClientEcPointFormatSuggest epf = modify' (\st -> st{stClientEcPointFormatSuggest = Just epf}) getClientEcPointFormatSuggest :: TLSSt (Maybe [EcPointFormat]) getClientEcPointFormatSuggest = gets stClientEcPointFormatSuggest setClientCertificateChain :: CertificateChain -> TLSSt ()-setClientCertificateChain s = modify (\st -> st{stClientCertificateChain = Just s})+setClientCertificateChain s = modify' (\st -> st{stClientCertificateChain = Just s}) getClientCertificateChain :: TLSSt (Maybe CertificateChain) getClientCertificateChain = gets stClientCertificateChain setServerCertificateChain :: CertificateChain -> TLSSt ()-setServerCertificateChain s = modify (\st -> st{stServerCertificateChain = Just s})+setServerCertificateChain s = modify' (\st -> st{stServerCertificateChain = Just s}) getServerCertificateChain :: TLSSt (Maybe CertificateChain) getServerCertificateChain = gets stServerCertificateChain setClientSNI :: HostName -> TLSSt ()-setClientSNI hn = modify (\st -> st{stClientSNI = Just hn})+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- resuming <- isSessionResuming- if resuming- then gets stServerVerifyData- else gets stClientVerifyData+ ver <- getVersion+ case ver of+ TLS13 -> gets stServerVerifyData+ _ -> do+ resuming <- getTLS12SessionResuming+ if resuming+ then gets stServerVerifyData+ else gets stClientVerifyData getRole :: TLSSt Role getRole = gets stClientContext@@ -313,44 +331,44 @@ put (st{stRandomGen = rng'}) return a -setExporterSecret :: ByteString -> TLSSt ()-setExporterSecret key = modify (\st -> st{stExporterSecret = Just key})+setTLS12SessionTicket :: Ticket -> TLSSt ()+setTLS12SessionTicket t = modify' (\st -> st{stTLS12SessionTicket = Just t}) -getExporterSecret :: TLSSt (Maybe ByteString)-getExporterSecret = gets stExporterSecret+getTLS12SessionTicket :: TLSSt (Maybe Ticket)+getTLS12SessionTicket = gets stTLS12SessionTicket +setTLS13ExporterSecret :: Secret -> TLSSt ()+setTLS13ExporterSecret key = modify' (\st -> st{stTLS13ExporterSecret = Just key})++getTLS13ExporterSecret :: TLSSt (Maybe Secret)+getTLS13ExporterSecret = gets stTLS13ExporterSecret+ setTLS13KeyShare :: Maybe KeyShare -> TLSSt ()-setTLS13KeyShare mks = modify (\st -> st{stTLS13KeyShare = mks})+setTLS13KeyShare mks = modify' (\st -> st{stTLS13KeyShare = mks}) getTLS13KeyShare :: TLSSt (Maybe KeyShare) getTLS13KeyShare = gets stTLS13KeyShare setTLS13PreSharedKey :: Maybe PreSharedKey -> TLSSt ()-setTLS13PreSharedKey mpsk = modify (\st -> st{stTLS13PreSharedKey = mpsk})+setTLS13PreSharedKey mpsk = modify' (\st -> st{stTLS13PreSharedKey = mpsk}) getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey) getTLS13PreSharedKey = gets stTLS13PreSharedKey setTLS13HRR :: Bool -> TLSSt ()-setTLS13HRR b = modify (\st -> st{stTLS13HRR = b})+setTLS13HRR b = modify' (\st -> st{stTLS13HRR = b}) getTLS13HRR :: TLSSt Bool getTLS13HRR = gets stTLS13HRR setTLS13Cookie :: Maybe Cookie -> TLSSt ()-setTLS13Cookie mcookie = modify (\st -> st{stTLS13Cookie = mcookie})+setTLS13Cookie mcookie = modify' (\st -> st{stTLS13Cookie = mcookie}) getTLS13Cookie :: TLSSt (Maybe Cookie) getTLS13Cookie = gets stTLS13Cookie -setClientSupportsPHA :: Bool -> TLSSt ()-setClientSupportsPHA b = modify (\st -> st{stClientSupportsPHA = b})--getClientSupportsPHA :: TLSSt Bool-getClientSupportsPHA = gets stClientSupportsPHA--setTLS12SessionTicket :: Ticket -> TLSSt ()-setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t})+setTLS13ClientSupportsPHA :: Bool -> TLSSt ()+setTLS13ClientSupportsPHA b = modify' (\st -> st{stTLS13ClientSupportsPHA = b}) -getTLS12SessionTicket :: TLSSt (Maybe Ticket)-getTLS12SessionTicket = gets stTLS12SessionTicket+getTLS13ClientSupportsPHA :: TLSSt Bool+getTLS13ClientSupportsPHA = gets stTLS13ClientSupportsPHA
Network/TLS/Struct.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK hide #-} @@ -7,47 +7,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 +17,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 +29,6 @@ TLSError (..), TLSException (..), DistinguishedName,- BigNum (..),- bigNumToInteger,- bigNumFromInteger, ServerDHParams (..), serverDHParamsToParams, serverDHParamsToPublic,@@ -114,7 +42,7 @@ ServerRandom (..), ClientRandom (..), FinishedData,- VerifyData,+ VerifyData (..), SessionID, Session (..), SessionData (..),@@ -174,23 +102,41 @@ HandshakeType_CertVerify, HandshakeType_ClientKeyXchg, HandshakeType_Finished,- HandshakeType_KeyUpdate+ HandshakeType_KeyUpdate,+ HandshakeType_CompressedCertificate ),+ CertificateChain_ (..),+ emptyCertificateChain_, Handshake (..),- CH (..), packetType, typeOfHandshake,+ module Network.TLS.HashAndSignature,+ ExtensionRaw (..),+ ExtensionID (..),+ showCertificateChain,+ isHelloRetryRequest,+ hrrRandom,+ ClientHello (..),+ ServerHello (..),+ HandshakeR, ) 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 Data.X509 (+ CertificateChain (..),+ DistinguishedName,+ certSubjectDN,+ getCharacterStringRawData,+ getDistinguishedElements,+ getSigned,+ signedObject,+ )+ 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 ---------------------------------------------------------------- @@ -233,11 +179,11 @@ pattern CertificateType_Ed448_Sign = CertificateType 255 -- fixme: dummy value instance Show CertificateType where- show CertificateType_RSA_Sign = "CertificateType_RSA_Sign"- show CertificateType_DSA_Sign = "CertificateType_DSA_Sign"- show CertificateType_ECDSA_Sign = "CertificateType_ECDSA_Sign"- show CertificateType_Ed25519_Sign = "CertificateType_Ed25519_Sign"- show CertificateType_Ed448_Sign = "CertificateType_Ed448_Sign"+ show CertificateType_RSA_Sign = "rsa_sign"+ show CertificateType_DSA_Sign = "dss_sign"+ show CertificateType_ECDSA_Sign = "ecdsa_sign"+ show CertificateType_Ed25519_Sign = "ed25519_sign"+ show CertificateType_Ed448_Sign = "ed448_sign" show (CertificateType x) = "CertificateType " ++ show x {- FOURMOLU_ENABLE -} @@ -250,122 +196,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 ++ " \"...\""+ ---------------------------------------------------------------- newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq)@@ -393,347 +231,53 @@ ---------------------------------------------------------------- --- | 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]+ = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Eq) instance Show Packet where- show (Handshake hs) = "Handshake " ++ show hs+ 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.--- <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>-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------------------------------------------------------------------+instance Show ServerRandom where+ show sr@(ServerRandom bs)+ | isHelloRetryRequest sr = "HelloRetryReqest"+ | otherwise = "ServerRandom " ++ showBytesHex bs -newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq)+hrrRandom :: ServerRandom+hrrRandom =+ ServerRandom+ "\xCF\x21\xAD\x74\xE5\x9A\x61\x11\xBE\x1D\x8C\x02\x1E\x65\xB8\x91\xC2\xA2\x11\x16\x7A\xBB\x8C\x5E\x07\x9E\x09\xE2\xC8\xA8\x33\x9C" -{- FOURMOLU_DISABLE -}-pattern AlertLevel_Warning :: AlertLevel-pattern AlertLevel_Warning = AlertLevel 1-pattern AlertLevel_Fatal :: AlertLevel-pattern AlertLevel_Fatal = AlertLevel 2+isHelloRetryRequest :: ServerRandom -> Bool+isHelloRetryRequest = (== hrrRandom) -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 ---------------------------------------------------------------- @@ -741,63 +285,58 @@ deriving (Eq) {- FOURMOLU_DISABLE -}-pattern HandshakeType_HelloRequest :: HandshakeType-pattern HandshakeType_HelloRequest = HandshakeType 0-pattern HandshakeType_ClientHello :: HandshakeType-pattern HandshakeType_ClientHello = HandshakeType 1-pattern HandshakeType_ServerHello :: HandshakeType-pattern HandshakeType_ServerHello = HandshakeType 2-pattern HandshakeType_NewSessionTicket :: HandshakeType-pattern HandshakeType_NewSessionTicket = HandshakeType 4-pattern HandshakeType_EndOfEarlyData :: HandshakeType-pattern HandshakeType_EndOfEarlyData = HandshakeType 5-pattern HandshakeType_EncryptedExtensions :: HandshakeType-pattern HandshakeType_EncryptedExtensions = HandshakeType 8-pattern HandshakeType_Certificate :: HandshakeType-pattern HandshakeType_Certificate = HandshakeType 11-pattern HandshakeType_ServerKeyXchg :: HandshakeType-pattern HandshakeType_ServerKeyXchg = HandshakeType 12-pattern HandshakeType_CertRequest :: HandshakeType-pattern HandshakeType_CertRequest = HandshakeType 13-pattern HandshakeType_ServerHelloDone :: HandshakeType-pattern HandshakeType_ServerHelloDone = HandshakeType 14-pattern HandshakeType_CertVerify :: HandshakeType-pattern HandshakeType_CertVerify = HandshakeType 15-pattern HandshakeType_ClientKeyXchg :: HandshakeType-pattern HandshakeType_ClientKeyXchg = HandshakeType 16-pattern HandshakeType_Finished :: HandshakeType-pattern HandshakeType_Finished = HandshakeType 20-pattern HandshakeType_KeyUpdate :: HandshakeType-pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_HelloRequest :: HandshakeType+pattern HandshakeType_HelloRequest = HandshakeType 0+pattern HandshakeType_ClientHello :: HandshakeType+pattern HandshakeType_ClientHello = HandshakeType 1+pattern HandshakeType_ServerHello :: HandshakeType+pattern HandshakeType_ServerHello = HandshakeType 2+pattern HandshakeType_NewSessionTicket :: HandshakeType+pattern HandshakeType_NewSessionTicket = HandshakeType 4+pattern HandshakeType_EndOfEarlyData :: HandshakeType+pattern HandshakeType_EndOfEarlyData = HandshakeType 5+pattern HandshakeType_EncryptedExtensions :: HandshakeType+pattern HandshakeType_EncryptedExtensions = HandshakeType 8+pattern HandshakeType_Certificate :: HandshakeType+pattern HandshakeType_Certificate = HandshakeType 11+pattern HandshakeType_ServerKeyXchg :: HandshakeType+pattern HandshakeType_ServerKeyXchg = HandshakeType 12+pattern HandshakeType_CertRequest :: HandshakeType+pattern HandshakeType_CertRequest = HandshakeType 13+pattern HandshakeType_ServerHelloDone :: HandshakeType+pattern HandshakeType_ServerHelloDone = HandshakeType 14+pattern HandshakeType_CertVerify :: HandshakeType+pattern HandshakeType_CertVerify = HandshakeType 15+pattern HandshakeType_ClientKeyXchg :: HandshakeType+pattern HandshakeType_ClientKeyXchg = HandshakeType 16+pattern HandshakeType_Finished :: HandshakeType+pattern HandshakeType_Finished = HandshakeType 20+pattern HandshakeType_KeyUpdate :: HandshakeType+pattern HandshakeType_KeyUpdate = HandshakeType 24+pattern HandshakeType_CompressedCertificate :: HandshakeType+pattern HandshakeType_CompressedCertificate = HandshakeType 25 instance Show HandshakeType where- show HandshakeType_HelloRequest = "HandshakeType_HelloRequest"- show HandshakeType_ClientHello = "HandshakeType_ClientHello"- show HandshakeType_ServerHello = "HandshakeType_ServerHello"- show HandshakeType_Certificate = "HandshakeType_Certificate"- show HandshakeType_ServerKeyXchg = "HandshakeType_ServerKeyXchg"- show HandshakeType_CertRequest = "HandshakeType_CertRequest"- show HandshakeType_ServerHelloDone = "HandshakeType_ServerHelloDone"- show HandshakeType_CertVerify = "HandshakeType_CertVerify"- show HandshakeType_ClientKeyXchg = "HandshakeType_ClientKeyXchg"- show HandshakeType_Finished = "HandshakeType_Finished"- show HandshakeType_NewSessionTicket = "HandshakeType_NewSessionTicket"- show (HandshakeType x) = "HandshakeType " ++ show x+ show HandshakeType_HelloRequest = "HelloRequest"+ show HandshakeType_ClientHello = "ClientHello"+ show HandshakeType_ServerHello = "ServerHello"+ show HandshakeType_NewSessionTicket = "NewSessionTicket"+ show HandshakeType_EndOfEarlyData = "EndOfEarlyData"+ show HandshakeType_EncryptedExtensions = "EncryptedExtensions"+ show HandshakeType_Certificate = "Certificate"+ show HandshakeType_ServerKeyXchg = "ServerKeyXchg"+ show HandshakeType_CertRequest = "CertRequest"+ show HandshakeType_ServerHelloDone = "ServerHelloDone"+ show HandshakeType_CertVerify = "CertVerify"+ show HandshakeType_ClientKeyXchg = "ClientKeyXchg"+ show HandshakeType_Finished = "Finished"+ show HandshakeType_KeyUpdate = "KeyUpdate"+ show HandshakeType_CompressedCertificate = "CompressedCertificate"+ show (HandshakeType x) = "HandshakeType " ++ show x {- FOURMOLU_ENABLE -} ---------------------------------------------------------------- -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@@ -824,7 +363,7 @@ ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic+data ServerECDHParams = ServerECDHParams Group GroupPublicA deriving (Show, Eq) ----------------------------------------------------------------@@ -852,39 +391,79 @@ | 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 \"...\""+ show (CKX_DH pub) = "CKX_DH " ++ show pub+ show (CKX_ECDH _bs) = "CKX_ECDH \"...\""+ ---------------------------------------------------------------- -data CH = CH- { chSession :: Session- , chCiphers :: [CipherID]+newtype CertificateChain_ = CertificateChain_ CertificateChain deriving (Eq)+instance Show CertificateChain_ where+ show (CertificateChain_ cc) = showCertificateChain cc++emptyCertificateChain_ :: CertificateChain_+emptyCertificateChain_ = CertificateChain_ (CertificateChain [])++showCertificateChain :: CertificateChain -> String+showCertificateChain (CertificateChain xs) = show $ map getName xs+ where+ getName =+ maybe "" getCharacterStringRawData+ . lookup [2, 5, 4, 3]+ . getDistinguishedElements+ . certSubjectDN+ . signedObject+ . getSigned++data ClientHello = CH+ { chVersion :: Version+ , chRandom :: ClientRandom+ , chSession :: Session+ , chCiphers :: [CipherId]+ , chComps :: [CompressionID] , chExtensions :: [ExtensionRaw] }- deriving (Show, Eq)+ deriving (Eq, Show) +data ServerHello = SH+ { shVersion :: Version+ , shRandom :: ServerRandom+ , shSession :: Session+ , shCipher :: CipherId+ , shComp :: CompressionID+ , shExtensions :: [ExtensionRaw]+ }+ deriving (Eq, Show)+ data Handshake- = ClientHello- Version- ClientRandom- [CompressionID]- CH- | ServerHello- Version- ServerRandom- Session- CipherID- CompressionID- [ExtensionRaw]- | Certificate CertificateChain+ = ClientHello ClientHello+ | ServerHello ServerHello+ | Certificate CertificateChain_ | HelloRequest | ServerHelloDone | ClientKeyXchg ClientKeyXchgAlgorithmData@@ -900,7 +479,7 @@ {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType-packetType (Handshake _) = ProtocolType_Handshake+packetType (Handshake _ _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData@@ -918,3 +497,5 @@ typeOfHandshake Finished{} = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -}++type HandshakeR = (Handshake, WireBytes)
Network/TLS/Struct13.hs view
@@ -4,15 +4,19 @@ typeOfHandshake13, contentType, KeyUpdate (..),+ CertReqContext,+ isKeyUpdate13,+ TicketNonce (..),+ SessionIDorTicket_ (..),+ Handshake13R, ) where -import Data.X509 (CertificateChain) import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types data Packet13- = Handshake13 [Handshake13]+ = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString@@ -23,32 +27,45 @@ | UpdateRequested deriving (Show, Eq) -type TicketNonce = ByteString+newtype TicketNonce = TicketNonce ByteString deriving (Eq) +instance Show TicketNonce where+ show (TicketNonce bs) = showBytesHex bs++newtype SessionIDorTicket_ = SessionIDorTicket_ ByteString deriving (Eq)++instance Show SessionIDorTicket_ where+ show (SessionIDorTicket_ bs) = showBytesHex bs+ -- fixme: convert Word32 to proper data type data Handshake13- = ServerHello13 ServerRandom Session CipherID [ExtensionRaw]- | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw]+ = ServerHello13 ServerHello+ | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket_ [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw]+ | Certificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] | CertRequest13 CertReqContext [ExtensionRaw]- | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]]- | CertVerify13 HashAndSignatureAlgorithm Signature+ | CertVerify13 DigitallySigned | Finished13 VerifyData | KeyUpdate13 KeyUpdate+ | CompressedCertificate13 CertReqContext CertificateChain_ [[ExtensionRaw]] deriving (Show, Eq) +-- | Certificate request context for TLS 1.3.+type CertReqContext = ByteString+ {- FOURMOLU_DISABLE -} typeOfHandshake13 :: Handshake13 -> HandshakeType-typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello-typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData-typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket-typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions-typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest-typeOfHandshake13 Certificate13{} = HandshakeType_Certificate-typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify-typeOfHandshake13 Finished13{} = HandshakeType_Finished-typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello+typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket+typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData+typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions+typeOfHandshake13 Certificate13{} = HandshakeType_Certificate+typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest+typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify+typeOfHandshake13 Finished13{} = HandshakeType_Finished+typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate+typeOfHandshake13 CompressedCertificate13{} = HandshakeType_CompressedCertificate contentType :: Packet13 -> ProtocolType contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec@@ -56,3 +73,9 @@ contentType Alert13{} = ProtocolType_Alert contentType AppData13{} = ProtocolType_AppData {- FOURMOLU_ENABLE -}++isKeyUpdate13 :: Handshake13 -> Bool+isKeyUpdate13 (KeyUpdate13 _) = True+isKeyUpdate13 _ = False++type Handshake13R = (Handshake13, WireBytes)
Network/TLS/Types.hs view
@@ -1,186 +1,71 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE PatternSynonyms #-}- module Network.TLS.Types (- Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13),- SessionID,- SessionIDorTicket,- Ticket,- isTicket,- toSessionID,- SessionData (..),- 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,+ defaultRecordSizeLimit,+ TranscriptHash (..),+ WireBytes, ) 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)---- | 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+-- | Direction+data Direction = Tx | Rx+ deriving (Show, Eq) --- | Phantom type indicating application traffic secrets.-data ApplicationSecret+---------------------------------------------------------------- -data ResumptionSecret+newtype BigNum = BigNum ByteString+ deriving (Show, Eq) -newtype BaseSecret a = BaseSecret ByteString deriving (Show)-newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show)+bigNumToInteger :: BigNum -> Integer+bigNumToInteger (BigNum b) = os2ip b --- | A client traffic secret, typed with a parameter indicating a step in the--- TLS key schedule.-newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show)+bigNumFromInteger :: Integer -> BigNum+bigNumFromInteger i = BigNum $ i2osp i --- | 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)+-- For plaintext+-- 2^14 for TLS 1.2+-- 2^14 + 1 for TLS 1.3+defaultRecordSizeLimit :: Int+defaultRecordSizeLimit = 16384 -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)+newtype TranscriptHash = TranscriptHash ByteString --- Main secret for TLS 1.2 or earlier.-newtype MainSecret = MainSecret ByteString deriving (Show)+instance Show TranscriptHash where+ show (TranscriptHash bs) = showBytesHex bs ---------------------------------------------------------------- -instance Serialise Version-instance Serialise TLS13TicketInfo-instance Serialise SessionFlag-instance Serialise SessionData+type WireBytes = [ByteString]
+ Network/TLS/Types/Cipher.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.TLS.Types.Cipher where++import Crypto.Cipher.Types (AuthTag)+import Data.ByteArray (ScrubbedBytes)+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++----------------------------------------------------------------++type PlainText = ByteString+type CipherText = ByteString+type Secret = ScrubbedBytes+type Key = ScrubbedBytes+type IV = ByteString+type Nonce = ByteString -- aka IV+type AddDat = ByteString++----------------------------------------------------------------++-- | 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 BulkKey = Secret+type BulkIV = Nonce+type BulkNonce = Nonce+type BulkAdditionalData = ByteString++type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV)++newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream))++type BulkAEAD =+ BulkNonce -> ByteString -> BulkAdditionalData -> (ByteString, AuthTag)
+ Network/TLS/Types/Secret.hs view
@@ -0,0 +1,62 @@+module Network.TLS.Types.Secret where++import Data.ByteArray (convert)+import Network.TLS.Imports+import Network.TLS.Types.Cipher++-- | 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 Secret++instance Show (BaseSecret a) where+ show (BaseSecret bs) = showBytesHex $ convert bs++newtype AnyTrafficSecret a = AnyTrafficSecret Secret++instance Show (AnyTrafficSecret a) where+ show (AnyTrafficSecret bs) = showBytesHex $ convert bs++-- | A client traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule.+newtype ClientTrafficSecret a = ClientTrafficSecret Secret++instance Show (ClientTrafficSecret a) where+ show (ClientTrafficSecret bs) = showBytesHex $ convert bs++-- | A server traffic secret, typed with a parameter indicating a step in the+-- TLS key schedule.+newtype ServerTrafficSecret a = ServerTrafficSecret Secret++instance Show (ServerTrafficSecret a) where+ show (ServerTrafficSecret bs) = showBytesHex $ convert bs++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+ }+ deriving (Show)++-- | 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 Secret++instance Show MainSecret where+ show (MainSecret bs) = showBytesHex $ convert bs
+ Network/TLS/Types/Session.hs view
@@ -0,0 +1,73 @@+{-# 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+ , -- ScrubbedBytes is not an instance of Generic, sigh.+ 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
+ Network/TLS/Types/Version.hs view
@@ -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 0x0002+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
Network/TLS/Util.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.TLS.Util ( sub,@@ -16,12 +17,14 @@ restoreMVar, ) where +import Control.Concurrent.MVar+import Control.Exception (SomeAsyncException (..))+import qualified Control.Exception as E+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import Network.TLS.Imports -import Control.Concurrent.Async-import Control.Concurrent.MVar-import Control.Exception (SomeException)+import Network.TLS.Imports sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len@@ -46,18 +49,24 @@ (p3, _) = B.splitAt d3 r2 partition6- :: ByteString+ :: ScrubbedBytes -> (Int, Int, Int, Int, Int, Int)- -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString)-partition6 bytes (d1, d2, d3, d4, d5, d6) = if B.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6)+ -> Maybe+ ( ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ )+partition6 bytes (d1, d2, d3, d4, d5, d6) = if BA.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6) where- s = sum [d1, d2, d3, d4, d5, d6]- (p1, r1) = B.splitAt d1 bytes- (p2, r2) = B.splitAt d2 r1- (p3, r3) = B.splitAt d3 r2- (p4, r4) = B.splitAt d4 r3- (p5, r5) = B.splitAt d5 r4- (p6, _) = B.splitAt d6 r5+ slice' (beg, len) = BA.unsafeSlice bytes beg len+ lens = [d1, d2, d3, d4, d5, d6]+ s = sum lens+ begs = scanl (+) 0 lens+ ys = zip begs lens+ [p1, p2, p3, p4, p5, p6] = map slice' ys -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool@@ -69,8 +78,13 @@ fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f -catchException :: IO a -> (SomeException -> IO a) -> IO a-catchException action handler = withAsync action waitCatch >>= either handler return+catchException :: IO a -> (E.SomeException -> IO a) -> IO a+catchException f handler = E.catchJust filterExn f handler+ where+ filterExn :: E.SomeException -> Maybe E.SomeException+ filterExn e = case E.fromException (E.toException e) of+ Just (SomeAsyncException _) -> Nothing+ Nothing -> Just e forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b]) forEitherM [] _ = return (pure [])@@ -82,12 +96,12 @@ mapChunks_ :: Monad m => Maybe Int- -> (B.ByteString -> m a)- -> B.ByteString+ -> (ByteString -> m a)+ -> ByteString -> m () mapChunks_ len f = mapM_ f . getChunks len -getChunks :: Maybe Int -> B.ByteString -> [B.ByteString]+getChunks :: Maybe Int -> ByteString -> [ByteString] getChunks Nothing = (: []) getChunks (Just len) = go where
Network/TLS/Util/ASN1.hs view
@@ -7,6 +7,7 @@ import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.Types (ASN1Object, fromASN1, toASN1)+ import Network.TLS.Imports -- | Attempt to decode a bytestring representing
Network/TLS/Wire.hs view
@@ -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
Network/TLS/X509.hs view
@@ -10,12 +10,14 @@ CertificateUsage (..), CertificateStore, ValidationCache,+ defaultValidationCache, exceptionValidationCache, validateDefault, FailedReason, ServiceID, wrapCertificateChecks, pubkeyType,+ validateClientCertificate, ) where import Data.X509@@ -58,3 +60,23 @@ pubkeyType :: PubKey -> String pubkeyType = show . pubkeyToAlg++-- | A utility function for client authentication which can be used+-- `onClientCertificate`.+--+-- Since: 2.1.7+validateClientCertificate+ :: CertificateStore+ -> ValidationCache+ -> CertificateChain+ -> IO CertificateUsage+validateClientCertificate store cache cc =+ wrapCertificateChecks+ <$> validate+ HashSHA256+ defaultHooks+ defaultChecks{checkFQHN = False}+ store+ cache+ ("", mempty)+ cc
test/Arbitrary.hs view
@@ -5,15 +5,9 @@ import Control.Monad import qualified Data.ByteString as B-import Data.Default.Class import Data.List import Data.Word-import Data.X509 (- CertificateChain (..),- ExtKeyUsageFlag,- certPubKey,- getCertificate,- )+import Data.X509 (ExtKeyUsageFlag) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Internal@@ -56,12 +50,12 @@ arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where- arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32+ arbitrary = DigitallySigned . unsafeHead <$> arbitrary <*> genByteString 32 instance Arbitrary ExtensionRaw where arbitrary = let arbitraryContent = choose (0, 40) >>= genByteString- in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent+ in ExtensionRaw . ExtensionID <$> arbitrary <*> arbitraryContent instance Arbitrary CertificateType where arbitrary =@@ -71,28 +65,38 @@ , CertificateType_ECDSA_Sign ] +instance Arbitrary CipherId where+ arbitrary = CipherId <$> arbitrary+ instance Arbitrary Handshake where arbitrary = oneof [ arbitrary >>= \ver -> do- ClientHello ver- <$> arbitrary- <*> arbitraryCompressionIDs- <*> (CH <$> arbitrary <*> arbitraryCiphersIDs <*> arbitraryHelloExtensions ver)+ ClientHello+ <$> ( CH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitraryCiphersIds+ <*> arbitraryCompressionIDs+ <*> arbitraryHelloExtensions ver+ ) , arbitrary >>= \ver ->- ServerHello ver- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver- , Certificate . CertificateChain <$> resize 2 (listOf arbitraryX509)+ ServerHello+ <$> ( SH ver+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitraryHelloExtensions ver+ )+ , Certificate . CertificateChain_ . 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@@ -100,15 +104,18 @@ oneof [ arbitrary >>= \ver -> ServerHello13- <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitraryHelloExtensions ver+ <$> ( SH TLS12+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> pure 0+ <*> arbitraryHelloExtensions ver+ ) , NewSessionTicket13 <$> arbitrary <*> arbitrary- <*> genByteString 32 -- nonce- <*> genByteString 32 -- session ID+ <*> (TicketNonce <$> genByteString 32) -- nonce+ <*> (SessionIDorTicket_ <$> genByteString 32) -- session ID <*> arbitrary , pure EndOfEarlyData13 , EncryptedExtensions13 <$> arbitrary@@ -118,17 +125,21 @@ , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 <$> arbitraryCertReqContext- <*> return (CertificateChain certs)+ <*> return (CertificateChain_ (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@@ -305,11 +316,13 @@ -- versions for which we have compatible ciphers. Criteria about cipher -- ensure we can test version downgrade. let allowedVersions =- [ v | v <- knownVersions, or- [ x `elem` serverCiphers- && cipherAllowedForVersion v x- | x <- clientCiphers- ]+ [ v+ | v <- knownVersions+ , or+ [ x `elem` serverCiphers+ && cipherAllowedForVersion v x+ | x <- clientCiphers+ ] ] allowedVersionsFiltered = filter (<= connectVersion) allowedVersions -- Server or client is allowed to have versions > connectVersion, but not@@ -361,21 +374,22 @@ clientHashSignatures <- arbitrary serverHashSignatures <- arbitrary let serverState =- def+ defaultParamsServer { serverSupported =- def+ defaultSupported { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg- , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures+ , supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups] }- , serverShared = def{sharedCredentials = Credentials creds}+ , serverShared = defaultShared{sharedCredentials = Credentials creds} } let clientState = (defaultParamsClient "" B.empty) { clientSupported =- def+ defaultSupported { supportedCiphers = clientCiphers , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg@@ -383,7 +397,7 @@ , supportedHashSignatures = clientHashSignatures } , clientShared =- def+ defaultShared { sharedValidationCache = ValidationCache { cacheAdd = \_ _ _ -> return ()@@ -394,7 +408,7 @@ return (clientState, serverState) arbitraryClientCredential :: Version -> Gen Credential-arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements+arbitraryClientCredential _ = arbitraryCredentialsOfEachCurve' >>= elements arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey)@@ -431,3 +445,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
test/Certificate.hs view
@@ -9,6 +9,7 @@ arbitraryDN, simpleCertificate, simpleX509,+ getSignatureALG, toPubKeyEC, toPrivKeyEC, ) where
test/CiphersSpec.hs view
@@ -1,5 +1,6 @@ module CiphersSpec where +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -52,8 +53,8 @@ decrypted `shouldBe` t at `shouldBe` at2 -arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk)+arbitraryKey :: Bulk -> Gen BA.ScrubbedBytes+arbitraryKey bulk = BA.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk)@@ -61,7 +62,8 @@ arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString+data BulkTest+ = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString deriving (Show, Eq) instance Arbitrary BulkTest where
+ test/ECHSpec.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module ECHSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import Data.Maybe+import Network.TLS+import Network.TLS.ECH.Config+import Network.TLS.Extra.Cipher+import Network.TLS.Internal+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Arbitrary+import Run+import Session++spec :: Spec+spec = do+ describe "ECH" $ do+ prop "can handshake with TLS 1.3 Full" handshake13_full+ prop "can handshake with TLS 1.3 HRR" handshake13_hrr+ prop "can handshake with TLS 1.3 PSK" handshake13_psk+ prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket+ prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback+ prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt+ prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback+ prop "can handshake with TLS 1.3 EC groups" handshake13_ec+ prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+ describe "ECH greasing" $ do+ prop "sends greasing ECH" handshake13_greasing+ prop "sends greasing ECH HRR" handshake13_greasing_hrr++--------------------------------------------------------------++newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP13 where+ arbitrary = CSP13 <$> arbitraryPairParams13++--------------------------------------------------------------++handshake13_full :: CSP13 -> IO ()+handshake13_full (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_hrr :: CSP13 -> IO ()+handshake13_hrr (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params HelloRetryRequest++handshake13_psk :: CSP13 -> IO ()+handshake13_psk (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH params2 PreSharedKey++handshake13_psk_ticket :: CSP13 -> IO ()+handshake13_psk_ticket (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers0 = twoSessionManagers sessionRefs+ sessionManagers = (fst sessionManagers0, oneSessionTicket)++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSSimple13ECH params2 PreSharedKey++handshake13_psk_fallback :: CSP13 -> IO ()+handshake13_psk_fallback (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers =+ [ cipher13_AES_128_GCM_SHA256+ , cipher13_AES_128_CCM_SHA256+ ]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest++ -- resumption fails because GCM cipher is not supported anymore, full+ -- handshake is not possible because X25519 has been removed, so we are+ -- back with P256 after hello retry+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params+ srv2' = srv2{serverSupported = svrSupported'}+ svrSupported' =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_CCM_SHA256]+ , supportedGroups = [P256]+ , supportedGroupsTLS13 = [[P256]]+ }++ runTLSSimple13ECH (cli2, srv2') HelloRetryRequest++handshake13_0rtt :: CSP13 -> IO ()+handshake13_0rtt (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ cliHooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just ["h2"]+ }+ svrHooks =+ defaultServerHooks+ { onALPNClientSuggest = Just (return . unsafeHead)+ }+ params0 =+ setParams+ ( cli+ { clientSupported = cliSupported+ , clientHooks = cliHooks+ }+ , srv+ { serverSupported = svrSupported+ , serverHooks = svrHooks+ , serverEarlyDataSize = 2048+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSSimple13ECH params HelloRetryRequest+ runTLS0rtt params sessionRefs+ runTLS0rtt params sessionRefs+ where+ runTLS0rtt params sessionRefs = do+ -- and resume+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ clearClientSessionRef sessionRefs+ earlyData <- B.pack <$> generate (someWords8 256)+ let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ params2 = (pc{clientUseEarlyData = True}, ps)++ runTLS0RTTech params2 RTT0 earlyData++handshake13_0rtt_fallback :: CSP13 -> IO ()+handshake13_0rtt_fallback (CSP13 (cli, srv)) = do+ group0 <- generate $ elements [P256, X25519]+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group0]+ , supportedGroupsTLS13 = [[group0]]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv+ { serverSupported = svrSupported+ , serverEarlyDataSize = 1024+ }+ )++ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params0 = setPairParamsSessionManagers sessionManagers params++ let mode = if group0 == P256 then FullHandshake else HelloRetryRequest+ runTLSSimple13ECH params0 mode++ -- and resume+ mSessionParams <- readClientSessionRef sessionRefs+ case mSessionParams of+ Nothing -> expectationFailure "session params: Just is expected"+ Just sessionParams -> do+ earlyData <- B.pack <$> generate (someWords8 256)+ group1 <- generate $ elements [P256, X25519]+ let (pc, ps) = setPairParamsSessionResuming sessionParams params0+ svrSupported1 =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [group1]+ , supportedGroupsTLS13 = [[group1]]+ }+ params1 =+ ( pc{clientUseEarlyData = True}+ , ps+ { serverEarlyDataSize = 0+ , serverSupported = svrSupported1+ }+ )+ -- C: [P256, X25519]+ -- S: [group0]+ -- C: [P256, X25519]+ -- S: [group1]+ if group0 == group1+ -- 0-RTT is not allowed, so fallback to PreSharedKey+ then runTLS0RTTech params1 PreSharedKey earlyData+ -- HRR but not allowed for 0-RTT+ else runTLSFailure params1 (tlsClient earlyData) tlsServer+ where+ tlsClient earlyData ctx = do+ handshake ctx+ sendData ctx $ L.fromStrict earlyData+ _ <- recvData ctx+ bye ctx+ tlsServer ctx = do+ handshake ctx+ _ <- recvData ctx+ bye ctx++handshake13_ec :: CSP13 -> IO ()+handshake13_ec (CSP13 (cli, srv)) = do+ EC cgrps <- generate arbitrary+ EC sgrps <- generate arbitrary+ let cliSupported = (clientSupported cli){supportedGroups = cgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ }+ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_ffdhe :: CSP13 -> IO ()+handshake13_ffdhe (CSP13 (cli, srv)) = do+ FFDHE cgrps <- generate arbitrary+ FFDHE sgrps <- generate arbitrary+ let cliSupported = (clientSupported cli){supportedGroups = cgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ }++ params =+ setParams+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ runTLSSimple13ECH params FullHandshake++handshake13_greasing :: CSP13 -> IO ()+handshake13_greasing (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ ( cli+ { clientSupported = cliSupported+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True]++handshake13_greasing_hrr :: CSP13 -> IO ()+handshake13_greasing_hrr (CSP13 (cli, srv)) = do+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params =+ ( cli+ { clientSupported = cliSupported+ , clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ , srv{serverSupported = svrSupported}+ )+ (clientMessages, _) <- runTLSCaptureFail params+ let isGreasing (ExtensionRaw eid _) = eid == EID_EncryptedClientHello+ eeMessagesHaveExt =+ [ any isGreasing chExtensions+ | ClientHello CH{..} <- clientMessages+ ]+ eeMessagesHaveExt `shouldBe` [True, True]++expectJust :: String -> Maybe a -> Expectation+expectJust tag mx = case mx of+ Nothing -> expectationFailure tag+ Just _ -> return ()++setParams :: (ClientParams, ServerParams) -> (ClientParams, ServerParams)+setParams (cli, srv) = (cli', srv')+ where+ cli' =+ cli+ { clientUseECH = True+ , clientShared = (clientShared cli){sharedECHConfigList = echConfList}+ }+ srv' =+ srv+ { serverECHKey = echKey+ , serverShared = (serverShared srv){sharedECHConfigList = echConfList}+ }++echKey :: [(ConfigId, ByteString)]+echKey = [(0, B64.decodeLenient "GAl/YqzDDnssODe5t+2xlQsbSv26kNlfJ0D+nZbK62I=")]++echConfList :: ECHConfigList+echConfList =+ fromJust $+ decodeECHConfigList $+ B64.decodeLenient+ "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA"
test/HandshakeSpec.hs view
@@ -5,13 +5,13 @@ import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Default.Class import Data.IORef import Data.List import Data.Maybe import Data.X509 (ExtKeyUsageFlag (..)) import Network.TLS import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC import Network.TLS.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -48,6 +48,7 @@ prop "can resume with extended main secret" handshake_resumption_ems prop "can handle ALPN" handshake_alpn prop "can handle SNI" handshake_sni+ prop "can handshake with TLS 1.2 CBC" handshake_cbc prop "can re-negotiate with TLS 1.2" handshake12_renegotiation prop "can resume session with TLS 1.2" handshake12_session_resumption prop "can resume session ticket with TLS 1.2" handshake12_session_ticket@@ -99,10 +100,52 @@ 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 -------------------------------------------------------------- +handshake_cbc :: IO ()+handshake_cbc = do+ clientCiphers <- generate $ cipherGen >>= shuffle+ serverCiphers <- generate $ cipherGen >>= shuffle+ clientGroups <- generate $ groupGen >>= shuffle+ serverGroups <- generate $ groupGen >>= shuffle+ (clientParam, serverParam) <- generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS12], [TLS12])+ (clientCiphers, serverCiphers)+ let clientParam' = clientParam {+ clientSupported = (clientSupported clientParam)+ { supportedGroups = clientGroups } }+ serverParam' = serverParam {+ serverSupported = (serverSupported serverParam)+ { supportedGroups = serverGroups } }+ let ciphers = clientCiphers `intersect` serverCiphers+ groups = clientGroups `intersect` serverGroups+ in if compat ciphers groups+ then runTLSSimple (clientParam', serverParam')+ else runTLSFailure (clientParam', serverParam') handshake handshake+ where+ groupGen :: Gen [Group]+ groupGen = sublistOf grps `suchThat` (not . null)+ where+ grps = [X25519, P256, P384, FFDHE2048, FFDHE3072, FFDHE4096]++ cipherGen :: Gen [Cipher]+ cipherGen = sublistOf ciphersuite_pfs_sha2_cbc `suchThat` (not . null)++ compat :: [Cipher] -> [Group] -> Bool+ compat [] _ = False+ compat _ [] = False+ compat ciphers groups =+ let mustdh = all (== CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+ mustec = all (/= CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+ havedh = any (`elem` [FFDHE2048, FFDHE3072, FFDHE4096]) groups+ haveec = any (`elem` [X25519, P256, P384]) groups+ in ((not mustdh || havedh) && (not mustec || haveec))++--------------------------------------------------------------+ handshake13_downgrade :: (ClientParams, ServerParams) -> IO () handshake13_downgrade (cparam, sparam) = do versionForced <-@@ -128,9 +171,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 $@@ -210,6 +253,7 @@ { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups] } } commonGroups = clientGroups `intersect` serverGroups@@ -232,7 +276,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)@@ -259,6 +303,7 @@ { serverSupported = (serverSupported serverParam) { supportedGroups = sigGroups+ , supportedGroupsTLS13 = [sigGroups] , supportedHashSignatures = serverHashSignatures } , serverShared =@@ -285,15 +330,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 +386,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,14 +718,15 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli{clientSupported = cliSupported}@@ -691,14 +737,15 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli{clientSupported = cliSupported}@@ -709,14 +756,15 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -740,14 +788,15 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -772,17 +821,18 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -802,11 +852,13 @@ sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params- srv2' = srv2{serverSupported = svrSupported'}+ srv2' =+ srv2{serverSupported = svrSupported'} svrSupported' =- def- { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256]+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256]+ , supportedGroupsTLS13 = [[P256]] } runTLSSimple13 (cli2, srv2') HelloRetryRequest@@ -814,22 +866,23 @@ 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]+ , supportedGroupsTLS13 = [[X25519]] } cliHooks =- def+ defaultClientHooks { onSuggestALPN = return $ Just ["h2"] } svrHooks =- def- { onALPNClientSuggest = Just (return . head)+ defaultServerHooks+ { onALPNClientSuggest = Just (return . unsafeHead) } params0 = ( cli@@ -865,33 +918,33 @@ handshake13_0rtt_fallback :: CSP13 -> IO () handshake13_0rtt_fallback (CSP13 (cli, srv)) = do- maxEarlyDataSize <- generate $ choose (0, 512) 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]+ , supportedGroupsTLS13 = [[group0]] }- params0 =+ params = ( cli{clientSupported = cliSupported} , srv { serverSupported = svrSupported- , serverEarlyDataSize = maxEarlyDataSize+ , serverEarlyDataSize = 1024 } ) sessionRefs <- twoSessionRefs let sessionManagers = twoSessionManagers sessionRefs - let params = setPairParamsSessionManagers sessionManagers params0+ let params0 = setPairParamsSessionManagers sessionManagers params let mode = if group0 == P256 then FullHandshake else HelloRetryRequest- runTLSSimple13 params mode+ runTLSSimple13 params0 mode -- and resume mSessionParams <- readClientSessionRef sessionRefs@@ -900,11 +953,12 @@ Just sessionParams -> do earlyData <- B.pack <$> generate (someWords8 256) group1 <- generate $ elements [P256, X25519]- let (pc, ps) = setPairParamsSessionResuming sessionParams params+ let (pc, ps) = setPairParamsSessionResuming sessionParams params0 svrSupported1 =- def- { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1]+ , supportedGroupsTLS13 = [[group1]] } params1 = ( pc{clientUseEarlyData = True}@@ -913,9 +967,14 @@ , serverSupported = svrSupported1 } )-- if group1 == group0+ -- C: [P256, X25519]+ -- S: [group0]+ -- C: [P256, X25519]+ -- S: [group1]+ if group0 == group1+ -- 0-RTT is not allowed, so fallback to PreSharedKey then runTLS0RTT params1 PreSharedKey earlyData+ -- HRR but not allowed for 0-RTT else runTLSFailure params1 (tlsClient earlyData) tlsServer where tlsClient earlyData ctx = do@@ -933,13 +992,17 @@ let -- The client prefers P256 cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} -- The server prefers X25519- svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = [X25519, P256]+ , supportedGroupsTLS13 = [[X25519, P256]]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) (_, serverMessages) <- runTLSCapture13 params- -- The server should tell X25519 in supported_groups in EE to clinet+ -- The server should tell X25519 in supported_groups in EE to client let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups eeMessagesHaveExt = [ any isSupportedGroups exts@@ -952,7 +1015,11 @@ EC cgrps <- generate arbitrary EC sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported}@@ -964,7 +1031,11 @@ FFDHE cgrps <- generate arbitrary FFDHE sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported}
test/PubKey.hs view
@@ -91,6 +91,7 @@ knownECCurves = [ ECC.SEC_p256r1 , ECC.SEC_p384r1+ , ECC.SEC_p521r1 ] defaultECCurve :: ECC.CurveName
test/Run.hs view
@@ -6,12 +6,18 @@ runTLSSimple, runTLSPredicate, runTLSSimple13,+ runTLSSimple13ECH, runTLS0RTT,+ runTLS0RTTech, runTLSSimpleKeyUpdate,+ runTLSCaptureFail, runTLSCapture13, runTLSSuccess, runTLSFailure, expectMaybe,+ newPairContext,+ withDataPipe,+ byeBye, ) where import Control.Concurrent@@ -21,7 +27,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Default.Class import Data.IORef import Network.TLS import System.Timeout@@ -119,6 +124,25 @@ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode +runTLSSimple13ECH+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> IO ()+runTLSSimple13ECH params mode =+ runTLSSuccess params hsClient hsServer+ where+ hsClient ctx = do+ handshake ctx+ minfo <- contextGetInformation ctx+ let mmode = minfo >>= infoTLS13HandshakeMode+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ hsServer ctx = do+ handshake ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "S: mode should be Just" mode mmode+ runTLS0RTT :: (ClientParams, ServerParams) -> HandshakeMode13@@ -150,11 +174,68 @@ | len > 0 = [len] | otherwise = [] +runTLS0RTTech+ :: (ClientParams, ServerParams)+ -> HandshakeMode13+ -> ByteString+ -> IO ()+runTLS0RTTech params mode earlyData =+ withPairContext params $ \(cCtx, sCtx) ->+ concurrently_ (tlsServer sCtx) (tlsClient cCtx)+ where+ tlsClient ctx = do+ handshake ctx+ sendData ctx $ L.fromStrict earlyData+ _ <- recvData ctx+ bye ctx+ minfo <- contextGetInformation ctx+ let mmode = minfo >>= infoTLS13HandshakeMode+ maccepted = infoIsECHAccepted <$> minfo+ expectMaybe "C: mode should be Just" mode mmode+ expectMaybe "C: TLS accepted should be Just" True maccepted+ tlsServer ctx = do+ handshake ctx+ let ls = chunkLengths $ B.length earlyData+ chunks <- replicateM (length ls) $ recvData ctx+ (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData)+ sendData ctx $ L.fromStrict earlyData+ bye ctx+ mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx+ expectMaybe "S: mode should be Just" mode mmode+ chunkLengths :: Int -> [Int]+ chunkLengths len+ | len > 16384 = 16384 : chunkLengths (len - 16384)+ | len > 0 = [len]+ | otherwise = []+ expectMaybe :: (Show a, Eq a) => String -> a -> Maybe a -> Expectation expectMaybe tag e mx = case mx of Nothing -> expectationFailure tag Just x -> x `shouldBe` e +runTLSCaptureFail+ :: (ClientParams, ServerParams) -> IO ([Handshake], [Handshake])+runTLSCaptureFail params = do+ sRef <- newIORef []+ cRef <- newIORef []+ runTLSFailure params (hsClient cRef) (hsServer sRef)+ sReceived <- readIORef sRef+ cReceived <- readIORef cRef+ return (reverse sReceived, reverse cReceived)+ where+ hsClient ref ctx = do+ installHook ctx ref+ handshake ctx+ sendData ctx "Foo"+ hsServer ref ctx = do+ installHook ctx ref+ handshake ctx+ _ <- recvData ctx+ return ()+ installHook ctx ref =+ let recv hss = modifyIORef ref (hss :) >> return hss+ in contextHookSetHandshakeRecv ctx recv+ runTLSCapture13 :: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13]) runTLSCapture13 params = do@@ -273,8 +354,41 @@ logging pre = if debug then- def+ defaultLogging { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) }- else def+ else defaultLogging+++withDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> ((start -> IO (), IO result) -> IO a) -> IO a+withDataPipe params tlsServer tlsClient cont = do+ -- initial setup+ startQueue <- newChan+ resultQueue <- newChan++ (cCtx, sCtx) <- snd <$> newPairContext params++ withAsync (E.catch (tlsServer sCtx resultQueue)+ (printAndRaise "server" (serverSupported $ snd params))) $ \sAsync -> withAsync (E.catch (tlsClient startQueue cCtx)+ (printAndRaise "client" (clientSupported $ fst params))) $ \cAsync -> do+ let readResult = waitBoth cAsync sAsync >> readChan resultQueue+ cont (writeChan startQueue, readResult)++ where+ printAndRaise :: String -> Supported -> E.SomeException -> IO ()+ printAndRaise s supported e = do+ putStrLn $ s ++ " exception: " ++ show e +++ ", supported: " ++ show supported+ E.throwIO e++-- Terminate the write direction and wait to receive the peer EOF. This is+-- necessary in situations where we want to confirm the peer status, or to make+-- sure to receive late messages like session tickets. In the test suite this+-- is used each time application code ends the connection without prior call to+-- 'recvData'.+byeBye :: Context -> IO ()+byeBye ctx = do+ bye ctx+ bs <- recvData ctx+ unless (B.null bs) $ fail "byeBye: unexpected application data"
test/Session.hs view
@@ -32,7 +32,7 @@ -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref =- SessionManager+ noSessionManager { sessionResume = \myId -> readIORef ref >>= maybeResume False myId , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId , sessionEstablish = \myId dat -> writeIORef ref (Just (myId, dat)) >> return Nothing@@ -78,7 +78,7 @@ oneSessionTicket :: SessionManager oneSessionTicket =- SessionManager+ noSessionManager { sessionResume = resume , sessionResumeOnlyOnce = resume , sessionEstablish = \_ dat -> return $ Just $ L.toStrict $ serialise dat
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.0.2+version: 2.4.3 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -20,7 +20,7 @@ source-repository head type: git location: https://github.com/haskell-tls/hs-tls- subdir: core+ subdir: tls flag devel description: Development commands@@ -34,6 +34,7 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher+ Network.TLS.Extra.CipherCBC Network.TLS.Extra.FFDHE Network.TLS.QUIC @@ -50,6 +51,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@@ -63,7 +65,6 @@ Network.TLS.Handshake.Common13 Network.TLS.Handshake.Control Network.TLS.Handshake.Key- Network.TLS.Handshake.Process Network.TLS.Handshake.Random Network.TLS.Handshake.Server Network.TLS.Handshake.Server.ClientHello@@ -77,8 +78,12 @@ Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13+ Network.TLS.Handshake.TranscriptHash+ Network.TLS.HashAndSignature Network.TLS.Hooks Network.TLS.IO+ Network.TLS.IO.Decode+ Network.TLS.IO.Encode Network.TLS.Imports Network.TLS.KeySchedule Network.TLS.MAC@@ -87,91 +92,61 @@ Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.PostHandshake+ Network.TLS.RNG Network.TLS.Record- Network.TLS.Record.Disengage- Network.TLS.Record.Engage+ Network.TLS.Record.Decrypt+ Network.TLS.Record.Encrypt Network.TLS.Record.Layer- Network.TLS.Record.Reading- Network.TLS.Record.Writing+ Network.TLS.Record.Recv+ Network.TLS.Record.Send Network.TLS.Record.State Network.TLS.Record.Types- Network.TLS.RNG- Network.TLS.State Network.TLS.Session- Network.TLS.Sending- Network.TLS.Receiving+ Network.TLS.State+ Network.TLS.Types+ Network.TLS.Types.Cipher+ Network.TLS.Types.Secret+ Network.TLS.Types.Session+ Network.TLS.Types.Version Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization- Network.TLS.Types Network.TLS.Wire Network.TLS.X509 + default-language: Haskell2010 default-extensions: Strict StrictData- default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall build-depends: base >=4.9 && <5,- asn1-encoding >= 0.9 && < 0.10,- asn1-types >= 0.3 && < 0.4,- async >= 2.2 && < 2.3, base16-bytestring,- bytestring >= 0.10 && < 0.13,- cereal >= 0.5.3 && < 0.6,- crypton >= 0.34 && < 0.35,- crypton-x509 >= 1.7 && < 1.8,- crypton-x509-store >= 1.6 && < 1.7,- crypton-x509-validation >= 1.6.5 && < 1.7,- data-default-class >= 0.1 && < 0.2,- memory >= 0.18 && < 0.19,- mtl >= 2.2 && < 2.4,- network >= 3.1,- serialise >= 0.2 && < 0.3,- transformers >= 0.5 && < 0.7,- unix-time >= 0.4.11 && < 0.5--test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- build-tool-depends: hspec-discover:hspec-discover- hs-source-dirs: test- other-modules:- API- Arbitrary- Certificate- CiphersSpec- EncodeSpec- HandshakeSpec- PipeChan- PubKey- Run- Session- ThreadSpec-- default-extensions: Strict StrictData- default-language: Haskell2010- ghc-options: -Wall -threaded -rtsopts- build-depends:- base >=4.9 && <5,- QuickCheck,- asn1-types,- async,- bytestring,- crypton,- crypton-x509,- crypton-x509-validation,- data-default-class,- hourglass,- hspec,- serialise,- tls+ bytestring >=0.10 && <0.13,+ cereal >=0.5.3 && <0.6,+ crypton >=1.1.2 && <1.2,+ crypton-asn1-encoding >= 0.10.0 && < 0.11,+ crypton-asn1-types >= 0.4.1 && < 0.5,+ crypton-x509 >=1.9 && <1.10,+ crypton-x509-store >=1.9 && <1.10,+ crypton-x509-validation >=1.9 && <1.10,+ data-default,+ ech-config,+ hpke >=0.1.0 && <0.2,+ mlkem >= 0.2.0 && <0.3,+ mtl >=2.2 && <2.4,+ network >=3.1,+ ram >=0.22.0 && <0.23,+ random >=1.2 && <1.4,+ serialise >=0.2 && <0.3,+ transformers >=0.5 && <0.7,+ unix-time >=0.4.11 && <0.6,+ zlib >=0.7 && <0.8 -executable server- main-is: server.hs+executable tls-server+ main-is: tls-server.hs hs-source-dirs: util other-modules: Common- HexDump+ Server Imports default-language: Haskell2010@@ -179,13 +154,15 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5,+ base16-bytestring, bytestring, containers, crypton, crypton-x509-store, crypton-x509-system,- data-default-class,+ ech-config, network,+ network-run, tls if flag(devel)@@ -193,12 +170,12 @@ else buildable: False -executable client- main-is: client.hs+executable tls-client+ main-is: tls-client.hs hs-source-dirs: util other-modules:+ Client Common- HexDump Imports default-language: Haskell2010@@ -206,15 +183,98 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5,+ base16-bytestring, bytestring, crypton, crypton-x509-store, crypton-x509-system,- data-default-class,+ ech-config, network,+ network-run >=0.5, tls if flag(devel) else buildable: False++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test+ other-modules:+ API+ Arbitrary+ Certificate+ CiphersSpec+ ECHSpec+ EncodeSpec+ HandshakeSpec+ PipeChan+ PubKey+ Run+ Session+ ThreadSpec++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded -rtsopts+ build-depends:+ base >=4.9 && <5,+ QuickCheck,+ async,+ base64-bytestring,+ bytestring,+ crypton,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-validation,+ ech-config,+ hspec,+ ram,+ serialise,+ time-hourglass,+ tls++benchmark tls-bench+ type: exitcode-stdio-1.0+ main-is: Benchmarks.hs+ hs-source-dirs: Benchmarks test+ other-modules:+ API+ Arbitrary+ Certificate+ CiphersSpec+ ECHSpec+ EncodeSpec+ HandshakeSpec+ PipeChan+ PubKey+ Run+ Session+ ThreadSpec++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ QuickCheck,+ async,+ base64-bytestring,+ bytestring,+ containers,+ crypton,+ crypton-asn1-types,+ crypton-x509,+ crypton-x509-store,+ crypton-x509-validation,+ data-default,+ ech-config,+ hspec,+ network,+ network-run,+ serialise,+ tasty-bench,+ time-hourglass,+ tls
+ util/Client.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Client (+ Aux (..),+ Cli,+ clientHTTP11,+ clientDNS,+) where++import qualified Data.ByteString.Base16 as BS16+import qualified Data.ByteString.Char8 as C8+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++import Imports++data Aux = Aux+ { auxAuthority :: HostName+ , auxPort :: ServiceName+ , auxDebugPrint :: String -> IO ()+ , auxShow :: ByteString -> IO ()+ , auxReadResumptionData :: IO [(SessionID, SessionData)]+ }++type Cli = Aux -> NonEmpty ByteString -> Context -> IO ()++clientHTTP11 :: Cli+clientHTTP11 aux@Aux{..} paths ctx = do+ sendData ctx $+ CL8.fromStrict $+ "GET "+ <> NE.head paths+ <> " HTTP/1.1\r\n"+ <> "Host: "+ <> C8.pack auxAuthority+ <> "\r\n"+ <> "Connection: close\r\n"+ <> "\r\n"+ consume ctx aux++clientDNS :: Cli+clientDNS Aux{..} _paths ctx = do+ sendData+ ctx+ "\x00\x2c\xdc\xe3\x01\x00\x00\x01\x00\x00\x00\x00\x00\x01\x03\x77\x77\x77\x07\x65\x78\x61\x6d\x70\x6c\x65\x03\x63\x6f\x6d\x00\x00\x01\x00\x01\x00\x00\x29\x04\xd0\x00\x00\x00\x00\x00\x00"+ bs <- recvData ctx+ auxShow $ "Reply: " <> BS16.encode bs+ auxShow "\n"++consume :: Context -> Aux -> IO ()+consume ctx Aux{..} = loop+ where+ loop = do+ bs <- recvData ctx+ if bs == ""+ then auxShow "\n"+ else auxShow bs >> loop
util/Common.hs view
@@ -3,30 +3,27 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Common (- printCiphers, printDHParams, printGroups, readNumber,- readCiphers, readDHParams, readGroups,- printHandshakeInfo,- makeAddrInfo,- AddrInfo (..), getCertificateStore,+ getLogger,+ namedGroups,+ getInfo,+ printHandshakeInfo,+ showBytesHex, ) where +import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as C8 import Data.Char (isDigit)-import Network.Socket-import Numeric (showHex)--import Crypto.System.CPU import Data.X509.CertificateStore-import System.X509- import Network.TLS hiding (HostName)-import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE+import System.Exit+import System.X509 import Imports @@ -39,74 +36,41 @@ , ("ffdhe8192", ffdhe8192) ] -namedCiphersuites :: [(String, [CipherID])]-namedCiphersuites =- [ ("all", map cipherID ciphersuite_all)- , ("default", map cipherID ciphersuite_default)- , ("strong", map cipherID ciphersuite_strong)- ]-+{- FOURMOLU_DISABLE -} namedGroups :: [(String, Group)] namedGroups =- [ ("ffdhe2048", FFDHE2048)- , ("ffdhe3072", FFDHE3072)- , ("ffdhe4096", FFDHE4096)- , ("ffdhe6144", FFDHE6144)- , ("ffdhe8192", FFDHE8192)- , ("p256", P256)- , ("p384", P384)- , ("p521", P521)- , ("x25519", X25519)- , ("x448", X448)+ [ ("ffdhe2048", FFDHE2048)+ , ("ffdhe3072", FFDHE3072)+ , ("ffdhe4096", FFDHE4096)+ , ("ffdhe6144", FFDHE6144)+ , ("ffdhe8192", FFDHE8192)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448)+ , ("mlkem512", MLKEM512)+ , ("mlkem768", MLKEM768)+ , ("mlkem1024", MLKEM1024)+ , ("x25519mlkem768", X25519MLKEM768)+ , ("p256mlkem768", P256MLKEM768)+ , ("p384mlkem1024", P384MLKEM1024) ]+{- FOURMOLU_ENABLE -} readNumber :: (Num a, Read a) => String -> Maybe a readNumber s | 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 Nothing -> (Just . read) `fmap` readFile s mparams -> return mparams -readGroups :: String -> Maybe [Group]-readGroups s = traverse (`lookup` namedGroups) (split ',' s)--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)+readGroups :: String -> [Group]+readGroups s = fromMaybe [] $ traverse (`lookup` namedGroups) (split ',' s) printDHParams :: IO () printDHParams = do@@ -121,43 +85,12 @@ putStrLn "=====================================" forM_ namedGroups $ \(name, _) -> putStrLn name -printHandshakeInfo :: Context -> IO ()-printHandshakeInfo ctx = do- info <- contextGetInformation ctx- case info of- Nothing -> return ()- Just i -> do- putStrLn ("version: " ++ show (infoVersion i))- putStrLn ("cipher: " ++ show (infoCipher i))- putStrLn ("compression: " ++ show (infoCompression i))- putStrLn ("group: " ++ maybe "(none)" show (infoSupportedGroup i))- when (infoVersion i < TLS13) $ do- putStrLn ("extended master secret: " ++ show (infoExtendedMainSecret i))- putStrLn ("resumption: " ++ show (infoTLS12Resumption i))- when (infoVersion i == TLS13) $ do- putStrLn ("handshake emode: " ++ show (fromJust (infoTLS13HandshakeMode i)))- putStrLn ("early data accepted: " ++ show (infoIsEarlyDataAccepted i))- sni <- getClientSNI ctx- case sni of- Nothing -> return ()- Just n -> putStrLn ("server name indication: " ++ n)--makeAddrInfo :: Maybe HostName -> PortNumber -> IO AddrInfo-makeAddrInfo maddr port = do- let flgs = [AI_ADDRCONFIG, AI_NUMERICSERV, AI_PASSIVE]- hints =- defaultHints- { addrFlags = flgs- , addrSocketType = Stream- }- head <$> getAddrInfo (Just hints) maddr (Just $ show port)- 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@@ -168,3 +101,33 @@ case mstore of Nothing -> error ("invalid certificate store: " ++ path) Just st -> return $! mappend st acc++getLogger :: Maybe FilePath -> (String -> IO ())+getLogger Nothing = \_ -> return ()+getLogger (Just file) = \msg -> appendFile file (msg ++ "\n")++getInfo :: Context -> IO Information+getInfo ctx = do+ minfo <- contextGetInformation ctx+ case minfo of+ Nothing -> do+ putStrLn "Error: information cannot be obtained"+ exitFailure+ Just info -> return info++printHandshakeInfo :: Information -> IO ()+printHandshakeInfo i = do+ putStrLn $ "Version: " ++ show (infoVersion i)+ putStrLn $ "Cipher: " ++ show (infoCipher i)+ putStrLn $ "Compression: " ++ show (infoCompression i)+ putStrLn $ "Groups: " ++ maybe "(none)" show (infoSupportedGroup i)+ when (infoVersion i < TLS13) $ do+ putStrLn $ "Extended master secret: " ++ show (infoExtendedMainSecret i)+ putStrLn $ "Resumption: " ++ show (infoTLS12Resumption i)+ when (infoVersion i == TLS13) $ do+ putStrLn $ "Handshake mode: " ++ show (fromJust (infoTLS13HandshakeMode i))+ putStrLn $ "Early data accepted: " ++ show (infoIsEarlyDataAccepted i)+ putStrLn $ "Encrypted client hello accepted: " ++ show (infoIsECHAccepted i)++showBytesHex :: ByteString -> String+showBytesHex bs = C8.unpack $ B16.encode bs
− util/HexDump.hs
@@ -1,96 +0,0 @@-module HexDump (- hexdump,-) where--import qualified Data.ByteString as B--import Imports--hexdump :: String -> ByteString -> [String]-hexdump pre b = disptable (defaultConfig{configRowLeft = pre ++ " | "}) $ B.unpack b--data BytedumpConfig = BytedumpConfig- { configRowSize :: Int- -- ^ number of bytes per row.- , configRowGroupSize :: Int- -- ^ number of bytes per group per row.- , configRowGroupSep :: String- -- ^ string separating groups.- , configRowLeft :: String- -- ^ string on the left of the row.- , configRowRight :: String- -- ^ string on the right of the row.- , configCellSep :: String- -- ^ string separating cells in row.- , configPrintChar :: Bool- -- ^ if the printable ascii table is displayed.- }- deriving (Show, Eq)--defaultConfig :: BytedumpConfig-defaultConfig =- BytedumpConfig- { configRowSize = 16- , configRowGroupSize = 8- , configRowGroupSep = " : "- , configRowLeft = " | "- , configRowRight = " | "- , configCellSep = " "- , configPrintChar = True- }--disptable :: BytedumpConfig -> [Word8] -> [String]-disptable _ [] = []-disptable cfg x =- let (pre, post) = splitAt (configRowSize cfg) x- in tableRow pre : disptable cfg post- where- tableRow row =- let l = splitMultiple (configRowGroupSize cfg) $ map hexString row- in let lb = intercalate (configRowGroupSep cfg) $ map (intercalate (configCellSep cfg)) l- in let rb = map printChar row- in let rowLen =- 2 * configRowSize cfg- + (configRowSize cfg - 1) * length (configCellSep cfg)- + ((configRowSize cfg `div` configRowGroupSize cfg) - 1)- * length (configRowGroupSep cfg)- in configRowLeft cfg- ++ lb- ++ replicate (rowLen - length lb) ' '- ++ configRowRight cfg- ++ (if configPrintChar cfg then rb else "")-- splitMultiple _ [] = []- splitMultiple n l = let (pre, post) = splitAt n l in pre : splitMultiple n post-- printChar :: Word8 -> Char- printChar w- | w >= 0x20 && w < 0x7f = toEnum $ fromIntegral w- | otherwise = '.'-- hex :: Int -> Char- hex 0 = '0'- hex 1 = '1'- hex 2 = '2'- hex 3 = '3'- hex 4 = '4'- hex 5 = '5'- hex 6 = '6'- hex 7 = '7'- hex 8 = '8'- hex 9 = '9'- hex 10 = 'a'- hex 11 = 'b'- hex 12 = 'c'- hex 13 = 'd'- hex 14 = 'e'- hex 15 = 'f'- hex _ = ' '-- {-# INLINE hexBytes #-}- hexBytes :: Word8 -> (Char, Char)- hexBytes w = (hex h, hex l) where (h, l) = fromIntegral w `divMod` 16-- -- \| Dump one byte into a 2 hexadecimal characters.- hexString :: Word8 -> String- hexString i = [h, l] where (h, l) = hexBytes i
+ util/Server.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module Server where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy.Char8 as CL8+import Data.IORef+import Network.TLS+import Prelude hiding (getLine)++import Imports++-- "<>" creates *chunks* of lazy ByteString, resulting+-- many TLS fragments.+-- To prevent this, strict ByteString is created first and+-- converted into lazy one.+html :: CL8.ByteString+html =+ CL8.fromStrict $+ "HTTP/1.1 200 OK\r\n"+ <> "Context-Type: text/html\r\n"+ <> "Content-Length: "+ <> C8.pack (show (BS.length body))+ <> "\r\n"+ <> "\r\n"+ <> body+ where+ body = "<html><<body>Hello world!</body></html>"++server :: Context -> Bool -> IO ()+server ctx showRequest = do+ bs <- recvData ctx+ case C8.uncons bs of+ Nothing -> return ()+ Just ('A', _) -> do+ sendData ctx $ CL8.fromStrict bs+ echo ctx+ Just _ -> handleHTML ctx showRequest bs++echo :: Context -> IO ()+echo ctx = loop+ where+ loop = do+ bs <- recvData ctx+ when (bs /= "") $ do+ sendData ctx $ CL8.fromStrict bs+ loop++handleHTML :: Context -> Bool -> ByteString -> IO ()+handleHTML ctx showRequest ini = do+ getLine <- newSource ctx ini+ process getLine+ where+ process 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 ("GET /secret" `BS.isPrefixOf` bs) $ do+ r <- requestCertificate ctx+ putStrLn $ "Post handshake authentication..." ++ if r then "OK" else "NG"+ when (bs /= "") $ do+ when showRequest $ do+ BS.putStr bs+ BS.putStr "\n"+ consume getLine+ sendData ctx html+ consume getLine = do+ bs <- getLine+ when (bs /= "") $ do+ when showRequest $ do+ BS.putStr bs+ BS.putStr "\n"+ consume getLine++newSource :: Context -> ByteString -> IO (IO ByteString)+newSource ctx ini = do+ ref <- newIORef ini+ return $ getline ref+ where+ getline :: IORef ByteString -> IO ByteString+ getline ref = do+ bs0 <- readIORef ref+ case BS.breakSubstring "\n" bs0 of+ (_, "") -> do+ bs1 <- recvData ctx+ writeIORef ref (bs0 <> bs1)+ getline ref+ (bs1, bs2) -> do+ writeIORef ref $ BS.drop 1 bs2+ return $ BS.dropWhileEnd (== 0x0d) bs1
− util/client.hs
@@ -1,515 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Control.Exception (SomeException (..))-import qualified Control.Exception as E-import Crypto.Random-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Default.Class-import Data.IORef-import Data.X509.CertificateStore-import Network.Socket (PortNumber, close, connect, socket)-import System.Console.GetOpt-import System.Environment-import System.Exit-import System.IO-import System.Timeout--import Network.TLS-import Network.TLS.Extra.Cipher--import Common-import HexDump-import Imports--defaultBenchAmount :: Int-defaultBenchAmount = 1024 * 1024--defaultTimeout :: Int-defaultTimeout = 2000--bogusCipher :: CipherID -> Cipher-bogusCipher cid = cipher_ECDHE_RSA_AES128GCM_SHA256{cipherID = cid}--runTLS- :: Bool- -> Bool- -> ClientParams- -> String- -> PortNumber- -> (Context -> IO a)- -> IO a-runTLS debug ioDebug params hostname portNumber f =- E.bracket setup teardown $ \sock -> do- ctx <- contextNew sock params- contextHookSetLogging ctx getLogging- f ctx- where- getLogging = ioLogging $ packetLogging def- packetLogging logging- | debug =- logging- { loggingPacketSent = putStrLn . ("debug: >> " ++)- , loggingPacketRecv = putStrLn . ("debug: << " ++)- }- | otherwise = logging- ioLogging logging- | ioDebug =- logging- { loggingIOSent = mapM_ putStrLn . hexdump ">>"- , loggingIORecv = \hdr body -> do- putStrLn ("<< " ++ show hdr)- mapM_ putStrLn $ hexdump "<<" body- }- | otherwise = logging- setup = do- ai <- makeAddrInfo (Just hostname) portNumber- sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)- let sockaddr = addrAddress ai- connect sock sockaddr- return sock- teardown sock = close sock--sessionRef :: IORef (SessionID, SessionData) -> SessionManager-sessionRef ref =- noSessionManager- { sessionEstablish = \sid sdata -> writeIORef ref (sid, sdata) >> return Nothing- }--getDefaultParams- :: [Flag]- -> String- -> CertificateStore- -> IORef (SessionID, SessionData)- -> Maybe OnCertificateRequest- -> Maybe (SessionID, SessionData)- -> Maybe ByteString- -> ClientParams-getDefaultParams flags host store sStorage certCredsRequest session earlyData =- (defaultParamsClient serverName BC.empty)- { clientSupported =- def- { supportedVersions = supportedVers- , supportedCiphers = myCiphers- , supportedGroups = getGroups flags- }- , clientWantSessionResume = session- , clientUseServerNameIndication = NoSNI `notElem` flags- , clientShared =- def- { sharedSessionManager = sessionRef sStorage- , sharedCAStore = store- , sharedValidationCache = validateCache- }- , clientHooks =- def- { onCertificateRequest = fromMaybe (onCertificateRequest def) certCredsRequest- }- , clientDebug =- def- { debugSeed = foldl getDebugSeed Nothing flags- , debugPrintSeed =- if DebugPrintSeed `elem` flags- then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed)))- else (\_ -> return ())- }- , clientUseEarlyData = isJust earlyData- }- where- serverName = foldl f host flags- where- f _ (SNI n) = n- f acc _ = acc-- validateCache- | validateCert = def- | otherwise =- ValidationCache- (\_ _ _ -> return ValidationCachePass)- (\_ _ _ -> return ())- myCiphers = foldl accBogusCipher getSelectedCiphers flags- where- accBogusCipher acc (BogusCipher c) =- case reads c of- [(v, "")] -> acc ++ [bogusCipher v]- _ -> acc- accBogusCipher acc _ = acc-- getUsedCipherIDs = foldl f [] flags- where- f acc (UseCipher am) =- case readCiphers am of- Just l -> l ++ acc- Nothing -> acc- f acc _ = acc-- getSelectedCiphers =- case getUsedCipherIDs of- [] -> ciphersuite_all- l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l-- getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed- getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed- getDebugSeed acc _ = acc-- tlsConnectVer- | Tls13 `elem` flags = TLS13- | Tls12 `elem` flags = TLS12- | Tls11 `elem` flags = TLS11- | Ssl3 `elem` flags = SSL3- | Tls10 `elem` flags = TLS10- | otherwise = TLS13- supportedVers- | NoVersionDowngrade `elem` flags = [tlsConnectVer]- | otherwise = filter (<= tlsConnectVer) allVers- allVers = [TLS13, TLS12, TLS11, TLS10, SSL3]- validateCert = NoValidateCert `notElem` flags--getGroups :: [Flag] -> [Group]-getGroups flags = case getGroup >>= readGroups of- Nothing -> defaultGroups- Just [] -> defaultGroups- Just groups -> groups- where- defaultGroups = supportedGroups def- getGroup = foldl f Nothing flags- where- f _ (NGroup g) = Just g- f acc _ = acc--data Flag- = Verbose- | Debug- | IODebug- | NoValidateCert- | Session- | Http11- | Ssl3- | Tls10- | Tls11- | Tls12- | Tls13- | SNI String- | NoSNI- | Uri String- | NoVersionDowngrade- | UserAgent String- | Input String- | Output String- | Timeout String- | BogusCipher String- | ClientCert String- | TrustAnchor String- | BenchSend- | BenchRecv- | BenchData String- | UseCipher String- | ListCiphers- | ListGroups- | DebugSeed String- | DebugPrintSeed- | NGroup String- | Help- | UpdateKey- deriving (Show, Eq)--options :: [OptDescr Flag]-options =- [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout"- , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout"- , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout"- , Option ['s'] ["session"] (NoArg Session) "try to resume a session"- , Option- ['Z']- ["zerortt"]- (ReqArg Input "inpfile")- "input for TLS 1.3 0RTT data"- , Option ['O'] ["output"] (ReqArg Output "stdout") "output "- , Option ['g'] ["group"] (ReqArg NGroup "group") "group"- , Option- ['t']- ["timeout"]- (ReqArg Timeout "timeout")- "timeout in milliseconds (2s by default)"- , Option- ['u']- ["update-key"]- (NoArg UpdateKey)- "Updating keys after sending the first request then sending the same request again (TLS 1.3 only)"- , Option- []- ["no-validation"]- (NoArg NoValidateCert)- "disable certificate validation"- , Option- []- ["client-cert"]- (ReqArg ClientCert "cert-file:key-file")- "add a client certificate to use with the server"- , Option- []- ["trust-anchor"]- (ReqArg TrustAnchor "pem-or-dir")- "use provided CAs instead of system certificate store"- , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"- , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0"- , Option- []- ["sni"]- (ReqArg SNI "server-name")- "use non-default server name indication"- , Option [] ["no-sni"] (NoArg NoSNI) "don't use server name indication"- , Option [] ["user-agent"] (ReqArg UserAgent "user-agent") "use a user agent"- , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0"- , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1"- , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2"- , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3 (default)"- , Option- []- ["bogocipher"]- (ReqArg BogusCipher "cipher-id")- "add a bogus cipher id for testing"- , Option- ['x']- ["no-version-downgrade"]- (NoArg NoVersionDowngrade)- "do not allow version downgrade"- , Option- []- ["uri"]- (ReqArg Uri "URI")- "optional URI requested by default /"- , Option ['h'] ["help"] (NoArg Help) "request help"- , Option- []- ["bench-send"]- (NoArg BenchSend)- "benchmark send path. only with compatible server"- , Option- []- ["bench-recv"]- (NoArg BenchRecv)- "benchmark recv path. only with compatible server"- , Option- []- ["bench-data"]- (ReqArg BenchData "amount")- "amount of data to benchmark with"- , Option- []- ["use-cipher"]- (ReqArg UseCipher "cipher-id")- "use a specific cipher"- , Option- []- ["list-ciphers"]- (NoArg ListCiphers)- "list all ciphers supported and exit"- , Option- []- ["list-groups"]- (NoArg ListGroups)- "list all groups supported and exit"- , Option- []- ["debug-seed"]- (ReqArg DebugSeed "debug-seed")- "debug: set a specific seed for randomness"- , Option- []- ["debug-print-seed"]- (NoArg DebugPrintSeed)- "debug: set a specific seed for randomness"- ]--noSession :: Maybe (SessionID, SessionData)-noSession = Nothing--runOn- :: (IORef (SessionID, SessionData), CertificateStore)- -> [Flag]- -> PortNumber- -> String- -> IO ()-runOn (sStorage, certStore) flags port hostname- | BenchSend `elem` flags = runBench True- | BenchRecv `elem` flags = runBench False- | otherwise = do- certCredRequest <- getCredRequest- doTLS certCredRequest noSession Nothing `E.catch` \(SomeException e) -> print e- when (Session `elem` flags) $ do- putStrLn "\nResuming the session..."- session <- readIORef sStorage- earlyData <- case getInput of- Nothing -> return Nothing- Just i -> Just <$> B.readFile i- doTLS certCredRequest (Just session) earlyData `E.catch` \(SomeException e) -> print e- where- runBench isSend =- runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- (getDefaultParams flags hostname certStore sStorage Nothing noSession Nothing)- hostname- port- $ \ctx -> do- handshake ctx- if isSend- then loopSendData getBenchAmount ctx- else loopRecvData getBenchAmount ctx- bye ctx- where- dataSend = BC.replicate 4096 'a'- loopSendData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- sendData ctx $- LC.fromChunks- [if bytes > B.length dataSend then dataSend else BC.take bytes dataSend]- loopSendData (bytes - B.length dataSend) ctx-- loopRecvData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- d <- recvData ctx- loopRecvData (bytes - B.length d) ctx-- doTLS certCredRequest sess earlyData = E.bracket setup teardown $ \out -> do- let query =- LC.pack- ( "GET "- ++ findURI flags- ++ ( if Http11 `elem` flags then " HTTP/1.1\r\nHost: " ++ hostname else " HTTP/1.0"- )- ++ userAgent- ++ "\r\n\r\n"- )- when- (Verbose `elem` flags)- (putStrLn "sending query:" >> LC.putStrLn query >> putStrLn "")- runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- ( getDefaultParams- flags- hostname- certStore- sStorage- certCredRequest- sess- earlyData- )- hostname- port- $ \ctx -> do- handshake ctx- when (Verbose `elem` flags) $ printHandshakeInfo ctx- case earlyData of- Just edata -> sendData ctx $ LC.fromStrict edata- _ -> return ()- sendData ctx query- loopRecv out ctx- when (UpdateKey `elem` flags) $ do- _tls13 <- updateKey ctx TwoWay- sendData ctx query- loopRecv out ctx- bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e- return ()- setup = maybe (return stdout) (\f -> openFile f AppendMode) getOutput- teardown out = when (isJust getOutput) $ hClose out- loopRecv out ctx = do- d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv- case d of- Nothing ->- when (Debug `elem` flags) (hPutStrLn stderr "timeout")- Just b- | BC.null b -> return ()- | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx-- getCredRequest =- case clientCert of- Nothing -> return Nothing- Just s ->- case break (== ':') s of- (_, "") -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- (cert, ':' : key) -> do- ecred <- credentialLoadX509 cert key- case ecred of- Left err -> error ("cannot load client certificate: " ++ err)- Right cred -> do- let certRequest _ = return $ Just cred- return $ Just certRequest- (_, _) -> error "wrong format for client-cert, expecting 'cert-file:key-file'"-- findURI [] = "/"- findURI (Uri u : _) = u- findURI (_ : xs) = findURI xs-- userAgent = maybe "" ("\r\nUser-Agent: " ++) mUserAgent- mUserAgent = foldl f Nothing flags- where- f _ (UserAgent ua) = Just ua- f acc _ = acc- getInput = foldl f Nothing flags- where- f _ (Input i) = Just i- f acc _ = acc- getOutput = foldl f Nothing flags- where- f _ (Output o) = Just o- f acc _ = acc- timeoutMs = foldl f defaultTimeout flags- where- f _ (Timeout t) = read t- f acc _ = acc- clientCert = foldl f Nothing flags- where- f _ (ClientCert c) = Just c- f acc _ = acc- getBenchAmount = foldl f defaultBenchAmount flags- where- f acc (BenchData am) = case readNumber am of- Nothing -> acc- Just i -> i- f acc _ = acc--getTrustAnchors :: [Flag] -> IO CertificateStore-getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)- where- getPaths (TrustAnchor path) acc = path : acc- getPaths _ acc = acc--printUsage :: IO ()-printUsage =- putStrLn $- usageInfo- "usage: client [opts] <hostname> [port]\n\n\t(port default to: 443)\noptions:\n"- options--main :: IO ()-main = do- args <- getArgs- let (opts, other, errs) = getOpt Permute options args- unless (null errs) $ do- print errs- exitFailure-- when (Help `elem` opts) $ do- printUsage- exitSuccess-- when (ListCiphers `elem` opts) $ do- printCiphers- exitSuccess-- when (ListGroups `elem` opts) $ do- printGroups- exitSuccess-- certStore <- getTrustAnchors opts- sStorage <- newIORef (error "storage ioref undefined")- case other of- [hostname] -> runOn (sStorage, certStore) opts 443 hostname- [hostname, port] -> runOn (sStorage, certStore) opts (fromInteger $ read port) hostname- _ -> printUsage >> exitFailure
− util/server.hs
@@ -1,492 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Control.Concurrent-import qualified Control.Exception as E-import Crypto.Random-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Default.Class-import Data.IORef-import qualified Data.Map.Strict as M-import Data.X509.CertificateStore-import Network.Socket (accept, bind, close, listen, socket)-import qualified Network.Socket as S-import System.Console.GetOpt-import System.Environment-import System.Exit-import System.IO-import System.Timeout--import Network.TLS-import Network.TLS.Extra.Cipher--import Common-import HexDump-import Imports--defaultBenchAmount :: Int-defaultBenchAmount = 1024 * 1024--defaultTimeout :: Int-defaultTimeout = 2000--bogusCipher :: CipherID -> Cipher-bogusCipher cid = cipher_ECDHE_RSA_AES128GCM_SHA256{cipherID = cid}--runTLS :: Bool -> Bool -> ServerParams -> S.Socket -> (Context -> IO a) -> IO a-runTLS debug ioDebug params cSock f = do- ctx <- contextNew cSock params- contextHookSetLogging ctx getLogging- f ctx- where- getLogging = ioLogging $ packetLogging def- packetLogging logging- | debug =- logging- { loggingPacketSent = putStrLn . ("debug: >> " ++)- , loggingPacketRecv = putStrLn . ("debug: << " ++)- }- | otherwise = logging- ioLogging logging- | ioDebug =- logging- { loggingIOSent = mapM_ putStrLn . hexdump ">>"- , loggingIORecv = \hdr body -> do- putStrLn ("<< " ++ show hdr)- mapM_ putStrLn $ hexdump "<<" body- }- | otherwise = logging--getDefaultParams- :: [Flag]- -> CertificateStore- -> SessionManager- -> Credential- -> Bool- -> IO ServerParams-getDefaultParams flags store smgr cred rtt0accept = do- dhParams <- case getDHParams flags of- Nothing -> return Nothing- Just name -> readDHParams name-- return- def- { serverWantClientCert = False- , serverCACertificates = []- , serverDHEParams = dhParams- , serverShared =- def- { sharedSessionManager = smgr- , sharedCAStore = store- , sharedValidationCache = validateCache- , sharedCredentials = Credentials [cred]- }- , serverSupported =- def- { supportedVersions = supportedVers- , supportedCiphers = myCiphers- , supportedGroups = getGroups flags- , supportedClientInitiatedRenegotiation = allowRenegotiation- }- , serverDebug =- def- { debugSeed = foldl getDebugSeed Nothing flags- , debugPrintSeed =- if DebugPrintSeed `elem` flags- then (\seed -> putStrLn ("seed: " ++ show (seedToInteger seed)))- else (\_ -> return ())- }- , serverEarlyDataSize = if rtt0accept then 2048 else 0- }- where- validateCache- | validateCert = def- | otherwise =- ValidationCache- (\_ _ _ -> return ValidationCachePass)- (\_ _ _ -> return ())-- myCiphers = foldl accBogusCipher getSelectedCiphers flags- where- accBogusCipher acc (BogusCipher c) =- case reads c of- [(v, "")] -> acc ++ [bogusCipher v]- _ -> acc- accBogusCipher acc _ = acc-- getUsedCipherIDs = foldl f [] flags- where- f acc (UseCipher am) =- case readCiphers am of- Just l -> l ++ acc- Nothing -> acc- f acc _ = acc-- getSelectedCiphers =- case getUsedCipherIDs of- [] -> ciphersuite_default- l -> mapMaybe (\cid -> find ((== cid) . cipherID) ciphersuite_all) l-- getDHParams opts = foldl accf Nothing opts- where- accf _ (DHParams file) = Just file- accf acc _ = acc-- getDebugSeed :: Maybe Seed -> Flag -> Maybe Seed- getDebugSeed _ (DebugSeed seed) = seedFromInteger `fmap` readNumber seed- getDebugSeed acc _ = acc-- tlsConnectVer- | Tls13 `elem` flags = TLS13- | Tls12 `elem` flags = TLS12- | Tls11 `elem` flags = TLS11- | Ssl3 `elem` flags = SSL3- | Tls10 `elem` flags = TLS10- | otherwise = TLS13- supportedVers- | NoVersionDowngrade `elem` flags = [tlsConnectVer]- | otherwise = filter (<= tlsConnectVer) allVers- allVers = [TLS13, TLS12, TLS11, TLS10, SSL3]- validateCert = NoValidateCert `notElem` flags- allowRenegotiation = AllowRenegotiation `elem` flags--getGroups :: [Flag] -> [Group]-getGroups flags = case getGroup >>= readGroups of- Nothing -> defaultGroups- Just [] -> defaultGroups- Just groups -> groups- where- defaultGroups = supportedGroups def- getGroup = foldl f Nothing flags- where- f _ (NGroup g) = Just g- f acc _ = acc--data Flag- = Verbose- | Debug- | IODebug- | NoValidateCert- | Http11- | Ssl3- | Tls10- | Tls11- | Tls12- | Tls13- | NoVersionDowngrade- | AllowRenegotiation- | Output String- | Timeout String- | BogusCipher String- | TrustAnchor String- | BenchSend- | BenchRecv- | BenchData String- | UseCipher String- | ListCiphers- | ListGroups- | ListDHParams- | Certificate String- | Key String- | DHParams String- | Rtt0- | DebugSeed String- | DebugPrintSeed- | NGroup String- | Help- deriving (Show, Eq)--options :: [OptDescr Flag]-options =- [ Option ['v'] ["verbose"] (NoArg Verbose) "verbose output on stdout"- , Option ['d'] ["debug"] (NoArg Debug) "TLS debug output on stdout"- , Option [] ["io-debug"] (NoArg IODebug) "TLS IO debug output on stdout"- , Option ['Z'] ["zerortt"] (NoArg Rtt0) "accept TLS 1.3 0RTT data"- , Option ['O'] ["output"] (ReqArg Output "stdout") "output "- , Option ['g'] ["group"] (ReqArg NGroup "group") "group"- , Option- ['t']- ["timeout"]- (ReqArg Timeout "timeout")- "timeout in milliseconds (2s by default)"- , Option- []- ["no-validation"]- (NoArg NoValidateCert)- "disable certificate validation"- , Option- []- ["trust-anchor"]- (ReqArg TrustAnchor "pem-or-dir")- "use provided CAs instead of system certificate store"- , Option [] ["http1.1"] (NoArg Http11) "use http1.1 instead of http1.0"- , Option [] ["ssl3"] (NoArg Ssl3) "use SSL 3.0"- , Option [] ["tls10"] (NoArg Tls10) "use TLS 1.0"- , Option [] ["tls11"] (NoArg Tls11) "use TLS 1.1"- , Option [] ["tls12"] (NoArg Tls12) "use TLS 1.2"- , Option [] ["tls13"] (NoArg Tls13) "use TLS 1.3 (default)"- , Option- []- ["bogocipher"]- (ReqArg BogusCipher "cipher-id")- "add a bogus cipher id for testing"- , Option- ['x']- ["no-version-downgrade"]- (NoArg NoVersionDowngrade)- "do not allow version downgrade"- , Option- []- ["allow-renegotiation"]- (NoArg AllowRenegotiation)- "allow client-initiated renegotiation"- , Option ['h'] ["help"] (NoArg Help) "request help"- , Option- []- ["bench-send"]- (NoArg BenchSend)- "benchmark send path. only with compatible server"- , Option- []- ["bench-recv"]- (NoArg BenchRecv)- "benchmark recv path. only with compatible server"- , Option- []- ["bench-data"]- (ReqArg BenchData "amount")- "amount of data to benchmark with"- , Option- []- ["use-cipher"]- (ReqArg UseCipher "cipher-id")- "use a specific cipher"- , Option- []- ["list-ciphers"]- (NoArg ListCiphers)- "list all ciphers supported and exit"- , Option- []- ["list-groups"]- (NoArg ListGroups)- "list all groups supported and exit"- , Option- []- ["list-dhparams"]- (NoArg ListDHParams)- "list all DH parameters supported and exit"- , Option- []- ["certificate"]- (ReqArg Certificate "certificate")- "certificate file"- , Option- []- ["debug-seed"]- (ReqArg DebugSeed "debug-seed")- "debug: set a specific seed for randomness"- , Option- []- ["debug-print-seed"]- (NoArg DebugPrintSeed)- "debug: set a specific seed for randomness"- , Option [] ["key"] (ReqArg Key "key") "certificate file"- , Option- []- ["dhparams"]- (ReqArg DHParams "dhparams")- "DH parameters (name or file)"- ]--loadCred :: Maybe FilePath -> Maybe FilePath -> IO Credential-loadCred (Just key) (Just cert) = do- res <- credentialLoadX509 cert key- case res of- Left err -> error ("cannot load certificate: " ++ err)- Right v -> return v-loadCred Nothing _ =- error "missing credential key"-loadCred _ Nothing =- error "missing credential certificate"--runOn :: (SessionManager, CertificateStore) -> [Flag] -> S.PortNumber -> IO ()-runOn (smgr, certStore) flags port = do- ai <- makeAddrInfo Nothing port- sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)- S.setSocketOption sock S.ReuseAddr 1- let sockaddr = addrAddress ai- bind sock sockaddr- listen sock 10- runOn' sock- close sock- where- runOn' sock- | BenchSend `elem` flags = runBench True sock- | BenchRecv `elem` flags = runBench False sock- | otherwise = do- -- certCredRequest <- getCredRequest- E.bracket- (maybe (return stdout) (\x -> openFile x AppendMode) getOutput)- (\out -> when (isJust getOutput) $ hClose out)- (doTLS sock)- runBench isSend sock = do- (cSock, cAddr) <- accept sock- putStrLn ("connection from " ++ show cAddr)- cred <- loadCred getKey getCertificate- params <- getDefaultParams flags certStore smgr cred False- runTLS False False params cSock $ \ctx ->- do- handshake ctx- if isSend- then loopSendData getBenchAmount ctx- else loopRecvData getBenchAmount ctx- bye ctx- `E.finally` close cSock- where- dataSend = BC.replicate 4096 'a'- loopSendData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- sendData ctx $- LC.fromChunks- [if bytes > B.length dataSend then dataSend else BC.take bytes dataSend]- loopSendData (bytes - B.length dataSend) ctx-- loopRecvData bytes ctx- | bytes <= 0 = return ()- | otherwise = do- d <- recvData ctx- loopRecvData (bytes - B.length d) ctx-- doTLS sock out = do- (cSock, cAddr) <- accept sock- putStrLn ("connection from " ++ show cAddr)-- cred <- loadCred getKey getCertificate- let rtt0accept = Rtt0 `elem` flags- params <- getDefaultParams flags certStore smgr cred rtt0accept-- void- $ forkIO- $ runTLS- (Debug `elem` flags)- (IODebug `elem` flags)- params- cSock- $ \ctx ->- do- handshake ctx- when (Verbose `elem` flags) $ printHandshakeInfo ctx- loopRecv out ctx- -- sendData ctx $ query- bye ctx- return ()- `E.finally` close cSock- doTLS sock out-- loopRecv out ctx = do- d <- timeout (timeoutMs * 1000) (recvData ctx) -- 2s per recv- case d of- Nothing ->- when (Debug `elem` flags) $ hPutStrLn stderr "timeout"- Just b- | BC.null b -> return ()- | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx-- {-- getCredRequest =- case clientCert of- Nothing -> return Nothing- Just s -> do- case break (== ':') s of- (_ ,"") -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- (cert,':':key) -> do- ecred <- credentialLoadX509 cert key- case ecred of- Left err -> error ("cannot load client certificate: " ++ err)- Right cred -> do- let certRequest _ = return $ Just cred- return $ Just (Credentials [cred], certRequest)- (_ ,_) -> error "wrong format for client-cert, expecting 'cert-file:key-file'"- -}-- getOutput = foldl f Nothing flags- where- f _ (Output o) = Just o- f acc _ = acc- timeoutMs = foldl f defaultTimeout flags- where- f _ (Timeout t) = read t- f acc _ = acc- getKey = foldl f Nothing flags- where- f _ (Key key) = Just key- f acc _ = acc- getCertificate = foldl f Nothing flags- where- f _ (Certificate cert) = Just cert- f acc _ = acc- getBenchAmount = foldl f defaultBenchAmount flags- where- f acc (BenchData am) = case readNumber am of- Nothing -> acc- Just i -> i- f acc _ = acc--getTrustAnchors :: [Flag] -> IO CertificateStore-getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags)- where- getPaths (TrustAnchor path) acc = path : acc- getPaths _ acc = acc--printUsage :: IO ()-printUsage =- putStrLn $- usageInfo- "usage: server [opts] [port]\n\n\t(port default to: 443)\noptions:\n"- options--main :: IO ()-main = do- args <- getArgs- let (opts, other, errs) = getOpt Permute options args- unless (null errs) $ do- print errs- exitFailure-- when (Help `elem` opts) $ do- printUsage- exitSuccess-- when (ListCiphers `elem` opts) $ do- printCiphers- exitSuccess-- when (ListDHParams `elem` opts) $ do- printDHParams- exitSuccess-- when (ListGroups `elem` opts) $ do- printGroups- exitSuccess-- certStore <- getTrustAnchors opts- smgr <- newSessionManager- case other of- [] -> runOn (smgr, certStore) opts 443- [port] -> runOn (smgr, certStore) opts (fromInteger $ read port)- _ -> printUsage >> exitFailure--newSessionManager :: IO SessionManager-newSessionManager = do- ref <- newIORef M.empty- return $- noSessionManager- { sessionResume = \key -> M.lookup key <$> readIORef ref- , sessionResumeOnlyOnce = \key -> M.lookup key <$> readIORef ref- , sessionEstablish = \key val -> atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)- , sessionInvalidate = \key -> atomicModifyIORef' ref $ \m -> (M.delete key m, ())- , sessionUseTicket = False- }
+ util/tls-client.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE BangPatterns #-}+{-# 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.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.ECH.Config+import Network.TLS.Internal (makeCipherShowPretty)+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.X509++import Client+import Common+import Imports++data Options = Options+ { optDebugLog :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optGroups :: [Group]+ , optValidate :: Bool+ , optVerNego :: Bool+ , optResumption :: Bool+ , opt0RTT :: Bool+ , optRetry :: Bool+ , optVersions :: [Version]+ , optALPN :: String+ , optCertFile :: Maybe FilePath+ , optKeyFile :: Maybe FilePath+ , optECHConfigFile :: Maybe FilePath+ , optTraceKey :: Bool+ , optIPv4Only :: Bool+ , optIPv6Only :: Bool+ , optTrustedAnchor :: Maybe FilePath+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optGroups = supportedGroups defaultSupported+ , optValidate = False+ , optVerNego = False+ , optResumption = False+ , opt0RTT = False+ , optRetry = False+ , optVersions = supportedVersions defaultSupported+ , optALPN = "http/1.1"+ , optCertFile = Nothing+ , optKeyFile = Nothing+ , optECHConfigFile = Nothing+ , optTraceKey = False+ , optIPv4Only = False+ , optIPv6Only = False+ , optTrustedAnchor = Nothing+ }++usage :: String+usage = "Usage: tls-client [OPTION] addr port [path]"++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "specify groups"+ , Option+ ['e']+ ["validate"]+ (NoArg (\o -> o{optValidate = True}))+ "validate server's certificate"+ , Option+ ['R']+ ["resumption"]+ (NoArg (\o -> o{optResumption = True}))+ "try session resumption"+ , Option+ ['Z']+ ["0rtt"]+ (NoArg (\o -> o{opt0RTT = True}))+ "try sending early data"+ , Option+ ['S']+ ["hello-retry"]+ (NoArg (\o -> o{optRetry = True}))+ "try client hello retry"+ , Option+ ['2']+ ["tls12"]+ (NoArg (\o -> o{optVersions = [TLS12]}))+ "use TLS 1.2"+ , Option+ ['3']+ ["tls13"]+ (NoArg (\o -> o{optVersions = [TLS13]}))+ "use TLS 1.3"+ , Option+ ['a']+ ["alpn"]+ (ReqArg (\a o -> o{optALPN = a}) "<alpn>")+ "set ALPN"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = Just fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = Just fl}) "<file>")+ "key file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["trace-key"]+ (NoArg (\o -> o{optTraceKey = True}))+ "Trace transcript hash"+ , Option+ ['4']+ []+ (NoArg (\o -> o{optIPv4Only = True, optIPv6Only = False}))+ "IPv4 only"+ , Option+ ['6']+ []+ (NoArg (\o -> o{optIPv6Only = True, optIPv4Only = False}))+ "IPv6 only"+ , Option+ ['t']+ ["trusted-anchor"]+ (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>")+ "trusted anchor file"+ ]++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ putStrLn $ " <groups> = " ++ intercalate "," (map fst namedGroups)+ exitFailure++clientOpts :: [String] -> IO (Options, [String])+clientOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ args <- getArgs+ (opts@Options{..}, ips) <- clientOpts args+ (host, port, paths) <- case ips of+ [] -> showUsageAndExit usage+ _ : [] -> showUsageAndExit usage+ h : p : [] -> return (h, p, ["/"])+ h : p : ps -> return (h, p, C8.pack <$> NE.fromList ps)+ when (null optGroups) $ do+ putStrLn "Error: unsupported groups"+ exitFailure+ let onCertReq = \_ -> case optCertFile of+ Just certFile -> case optKeyFile of+ Just keyFile -> do+ Right (!cc, !priv) <- credentialLoadX509 certFile keyFile+ return $ Just (cc, priv)+ _ -> return Nothing+ _ -> return Nothing+ ref <- newIORef []+ let debug+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return ()+ showContent+ | optShow = C8.putStr+ | otherwise = \_ -> return ()+ aux =+ Aux+ { auxAuthority = host+ , auxPort = port+ , auxDebugPrint = debug+ , auxShow = showContent+ , auxReadResumptionData = readIORef ref+ }+ mstore <- case optTrustedAnchor of+ Nothing ->+ if optValidate then Just <$> getSystemCertificateStore else return Nothing+ Just file -> do+ mstore' <- readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ echConfList <- case optECHConfigFile of+ Nothing -> return []+ Just ecnff ->+ loadECHConfigList ecnff `E.catch` \(E.SomeException _) -> do+ putStrLn $ ecnff ++ " is broken"+ exitFailure+ let cparams =+ getClientParams+ opts+ host+ port+ (smIORef ref)+ mstore+ onCertReq+ echConfList+ debug+ traceKey+ client+ | optALPN == "dot" = clientDNS+ | otherwise = clientHTTP11+ makeCipherShowPretty+ runClient opts client cparams aux paths++runClient+ :: Options -> Cli -> ClientParams -> Aux -> NonEmpty ByteString -> IO ()+runClient opts@Options{..} client cparams aux@Aux{..} paths = do+ auxDebugPrint "------------------------"+ (info1, msd) <- runTLS opts cparams aux $ \ctx -> do+ i1 <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i1+ client aux paths ctx+ msd' <- auxReadResumptionData+ return (i1, msd')+ if+ | optResumption ->+ if isResumptionPossible msd+ then do+ let cparams2 = modifyClientParams cparams msd False+ info2 <- runClient2 opts client cparams2 aux paths+ if infoVersion info1 == TLS12+ then do+ if infoTLS12Resumption info2+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ if infoTLS13HandshakeMode info2 == Just PreSharedKey+ then do+ putStrLn "Result: (R) TLS resumption ... OK"+ exitSuccess+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ else do+ putStrLn "Result: (R) TLS resumption ... NG"+ exitFailure+ | opt0RTT ->+ if is0RTTPossible info1 msd+ then do+ let cparams2 = modifyClientParams cparams msd True+ info2 <- runClient2 opts client cparams2 aux paths+ if infoTLS13HandshakeMode info2 == Just RTT0+ then do+ putStrLn "Result: (Z) 0-RTT ... OK"+ exitSuccess+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ else do+ putStrLn "Result: (Z) 0-RTT ... NG"+ exitFailure+ | optRetry ->+ if infoTLS13HandshakeMode info1 == Just HelloRetryRequest+ then do+ putStrLn "Result: (S) retry ... OK"+ exitSuccess+ else do+ putStrLn "Result: (S) retry ... NG"+ exitFailure+ | otherwise -> do+ putStrLn "Result: (H) handshake ... OK"+ when (optALPN == "http/1.1") $+ putStrLn "Result: (1) HTTP/1.1 transaction ... OK"+ exitSuccess++runClient2+ :: Options+ -> Cli+ -> ClientParams+ -> Aux+ -> NonEmpty ByteString+ -> IO Information+runClient2 opts@Options{..} client cparams aux@Aux{..} paths = do+ threadDelay 100000+ auxDebugPrint "<<<< next connection >>>>"+ auxDebugPrint "------------------------"+ runTLS opts cparams aux $ \ctx -> do+ if opt0RTT+ then do+ void $ client aux paths ctx+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ return i+ else do+ i <- getInfo ctx+ when optDebugLog $ printHandshakeInfo i+ void $ client aux paths ctx+ return i++runTLS+ :: Options+ -> ClientParams+ -> Aux+ -> (Context -> IO a)+ -> IO a+runTLS Options{..} cparams Aux{..} action =+ runTCPClientWithSettings settings auxAuthority auxPort $ \sock -> do+ ctx <- contextNew sock cparams+ when optDebugLog $+ contextHookSetLogging+ ctx+ defaultLogging+ { loggingPacketSent = putStrLn . (">> " ++)+ , loggingPacketRecv = putStrLn . ("<< " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "}} " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "{{ " ++ show hd ++ " " ++ showBytesHex bs+ }+ handshake ctx+ r <- action ctx+ bye ctx+ return r+ where+ select addrs+ | optIPv4Only = case NE.filter (\ai -> addrFamily ai == AF_INET) addrs of+ [] -> error "IPv4 address is not available"+ ai : _ -> ai+ | optIPv6Only = case NE.filter (\ai -> addrFamily ai == AF_INET6) addrs of+ [] -> error "IPv6 address is not available"+ ai : _ -> ai+ | otherwise = NE.head addrs+ settings =+ defaultSettings+ { settingsSelectAddrInfo = select+ }++modifyClientParams+ :: ClientParams -> [(SessionID, SessionData)] -> Bool -> ClientParams+modifyClientParams cparams ts early =+ cparams+ { clientWantSessionResumeList = ts+ , clientUseEarlyData = early+ }++getClientParams+ :: Options+ -> HostName+ -> ServiceName+ -> SessionManager+ -> Maybe CertificateStore+ -> OnCertificateRequest+ -> ECHConfigList+ -> (String -> IO ())+ -> (String -> IO ())+ -> ClientParams+getClientParams Options{..} serverName port sm mstore onCertReq echConfList printError traceKey =+ (defaultParamsClient serverName (C8.pack port))+ { clientSupported = supported+ , clientUseServerNameIndication = True+ , clientShared = shared+ , clientHooks = hooks+ , clientDebug = debug+ , clientUseECH = not (null echConfList)+ }+ where+ groups+ | optRetry = FFDHE8192 : optGroups+ | otherwise = optGroups+ shared =+ defaultShared+ { sharedSessionManager = sm+ , sharedCAStore = fromMaybe mempty mstore+ , sharedValidationCache = validateCache+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 8192+ }+ , sharedECHConfigList = echConfList+ }+ supported =+ defaultSupported+ { supportedVersions = optVersions+ , supportedGroups = groups+ }+ hooks =+ defaultClientHooks+ { onSuggestALPN = return $ Just [C8.pack optALPN]+ , onCertificateRequest = onCertReq+ }+ validateCache+ | isJust mstore = sharedValidationCache defaultShared+ | otherwise =+ ValidationCache+ (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ())+ debug =+ defaultDebugParams+ { debugKeyLogger = getLogger optKeyLogFile+ , debugError = printError+ , debugTraceKey = traceKey+ }++smIORef :: IORef [(SessionID, SessionData)] -> SessionManager+smIORef ref =+ noSessionManager+ { sessionEstablish = \sid sdata ->+ modifyIORef' ref (\xs -> (sid, sdata) : xs)+ >> printTicket sid sdata+ >> return Nothing+ }++printTicket :: SessionID -> SessionData -> IO ()+printTicket sid sdata = do+ C8.putStr $ "Ticket: " <> C8.take 16 (BS16.encode sid) <> "..., "+ putStrLn $ "0-RTT: " <> if sessionMaxEarlyDataSize sdata > 0 then "OK" else "NG"++isResumptionPossible :: [(SessionID, SessionData)] -> Bool+isResumptionPossible = not . null++is0RTTPossible :: Information -> [(SessionID, SessionData)] -> Bool+is0RTTPossible _ [] = False+is0RTTPossible info xs =+ infoVersion info == TLS13+ && any (\(_, sd) -> sessionMaxEarlyDataSize sd > 0) xs
+ util/tls-server.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Data.IORef+import qualified Data.Map.Strict as M+import Data.X509.CertificateStore+import Network.Run.TCP+import Network.TLS+import Network.TLS.ECH.Config+import Network.TLS.Internal+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit+import System.IO+import System.X509++import Common+import Imports+import Server++data Options = Options+ { optDebugLog :: Bool+ , optClientAuth :: Bool+ , optShow :: Bool+ , optKeyLogFile :: Maybe FilePath+ , optTrustedAnchor :: Maybe FilePath+ , optGroups :: [Group]+ , optCertFile :: FilePath+ , optKeyFile :: FilePath+ , optECHConfigFile :: Maybe FilePath+ , optECHKeyFile :: Maybe FilePath+ , optTraceKey :: Bool+ }+ deriving (Show)++defaultOptions :: Options+defaultOptions =+ Options+ { optDebugLog = False+ , optClientAuth = False+ , optShow = False+ , optKeyLogFile = Nothing+ , optTrustedAnchor = Nothing+ , -- excluding FFDHE8192 for retry+ optGroups = FFDHE8192 `delete` supportedGroups defaultSupported+ , optCertFile = "servercert.pem"+ , optKeyFile = "serverkey.pem"+ , optECHConfigFile = Nothing+ , optECHKeyFile = Nothing+ , optTraceKey = False+ }++options :: [OptDescr (Options -> Options)]+options =+ [ Option+ ['a']+ ["client-auth"]+ (NoArg (\o -> o{optClientAuth = True}))+ "require client authentication"+ , Option+ ['d']+ ["debug"]+ (NoArg (\o -> o{optDebugLog = True}))+ "print debug info"+ , Option+ ['v']+ ["show-content"]+ (NoArg (\o -> o{optShow = True}))+ "print downloaded content"+ , Option+ ['l']+ ["key-log-file"]+ (ReqArg (\file o -> o{optKeyLogFile = Just file}) "<file>")+ "a file to store negotiated secrets"+ , Option+ ['g']+ ["groups"]+ (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ "groups for key exchange"+ , Option+ ['c']+ ["cert"]+ (ReqArg (\fl o -> o{optCertFile = fl}) "<file>")+ "certificate file"+ , Option+ ['k']+ ["key"]+ (ReqArg (\fl o -> o{optKeyFile = fl}) "<file>")+ "key file"+ , Option+ ['t']+ ["trusted-anchor"]+ (ReqArg (\fl o -> o{optTrustedAnchor = Just fl}) "<file>")+ "trusted anchor file"+ , Option+ []+ ["ech-config"]+ (ReqArg (\fl o -> o{optECHConfigFile = Just fl}) "<file>")+ "ECH config file"+ , Option+ []+ ["ech-key"]+ (ReqArg (\fl o -> o{optECHKeyFile = Just fl}) "<file>")+ "ECH key file"+ , Option+ []+ ["trace-key"]+ (NoArg (\o -> o{optTraceKey = True}))+ "Trace transcript hash"+ ]++usage :: String+usage = "Usage: tls-server [OPTION] addr port"++showUsageAndExit :: String -> IO a+showUsageAndExit msg = do+ putStrLn msg+ putStrLn $ usageInfo usage options+ exitFailure++serverOpts :: [String] -> IO (Options, [String])+serverOpts argv =+ case getOpt Permute options argv of+ (o, n, []) -> return (foldl (flip id) defaultOptions o, n)+ (_, _, errs) -> showUsageAndExit $ concat errs++main :: IO ()+main = do+ hSetBuffering stdout NoBuffering+ args <- getArgs+ (Options{..}, ips) <- serverOpts args+ (host, port) <- case ips of+ [h, p] -> return (h, p)+ _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"+ when (null optGroups) $ do+ putStrLn "Error: unsupported groups"+ exitFailure+ smgr <- newSessionManager+ Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile+ mstore <- do+ mstore' <- case optTrustedAnchor of+ Nothing -> Just <$> getSystemCertificateStore+ Just file -> readCertificateStore file+ when (isNothing mstore') $ showUsageAndExit "cannot set trusted anchor"+ return mstore'+ ech <- case optECHKeyFile of+ Nothing -> case optECHConfigFile of+ Nothing -> return ([], [])+ Just _ -> showUsageAndExit "must specify ECH key file, too"+ Just ekeyf -> case optECHConfigFile of+ Nothing -> showUsageAndExit "must specify ECH config file, too"+ Just ecnff -> do+ ekey <- loadECHSecretKeys [ekeyf]+ ecnf <- loadECHConfigList ecnff+ return (ekey, ecnf)+ let keyLog = getLogger optKeyLogFile+ printError+ | optDebugLog = putStrLn+ | otherwise = \_ -> return ()+ traceKey+ | optTraceKey = putStrLn+ | otherwise = \_ -> return ()+ creds = Credentials [cred]+ makeCipherShowPretty+ runTCPServer (Just host) port $ \sock -> do+ let sparams =+ getServerParams+ creds+ optGroups+ smgr+ keyLog+ optClientAuth+ mstore+ ech+ printError+ traceKey+ ctx <- contextNew sock sparams+ when optDebugLog $+ contextHookSetLogging+ ctx+ defaultLogging+ { loggingPacketSent = putStrLn . ("<< " ++)+ , loggingPacketRecv = putStrLn . (">> " ++)+ -- , loggingIOSent = \bs -> putStrLn $ "{{ " ++ showBytesHex bs+ -- , loggingIORecv = \hd bs -> putStrLn $ "}} " ++ show hd ++ " " ++ showBytesHex bs+ }+ when (optDebugLog || optShow) $ putStrLn "------------------------"+ handshake ctx+ when optDebugLog $+ getInfo ctx >>= printHandshakeInfo+ server ctx optShow+ bye ctx++getServerParams+ :: Credentials+ -> [Group]+ -> SessionManager+ -> (String -> IO ())+ -> Bool+ -> Maybe CertificateStore+ -> ([(Word8, ByteString)], ECHConfigList)+ -> (String -> IO ())+ -> (String -> IO ())+ -> ServerParams+getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey =+ defaultParamsServer+ { serverSupported = supported+ , serverShared = shared+ , serverHooks = hooks+ , serverDebug = debug+ , serverEarlyDataSize = 2048+ , serverWantClientCert = clientAuth+ , serverECHKey = ekey+ }+ where+ shared =+ defaultShared+ { sharedCredentials = creds+ , sharedSessionManager = sm+ , sharedCAStore = case mstore of+ Just store -> store+ Nothing -> sharedCAStore defaultShared+ , sharedECHConfigList = ecnf+ , sharedLimit =+ defaultLimit+ { limitRecordSize = Just 16384+ }+ }+ supported =+ defaultSupported+ { supportedGroups = groups+ }+ hooks =+ defaultServerHooks+ { onALPNClientSuggest = Just chooseALPN+ , onClientCertificate = case mstore of+ Nothing -> onClientCertificate defaultServerHooks+ Just _ ->+ validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ }+ debug =+ defaultDebugParams+ { debugKeyLogger = keyLog+ , debugError = printError+ , debugTraceKey = traceKey+ }++chooseALPN :: [ByteString] -> IO ByteString+chooseALPN protos+ | "http/1.1" `elem` protos = return "http/1.1"+ | otherwise = return ""++newSessionManager :: IO SessionManager+newSessionManager = do+ ref <- newIORef M.empty+ return $+ noSessionManager+ { sessionResume = \key -> do+ M.lookup key <$> readIORef ref+ , sessionResumeOnlyOnce = \key -> do+ M.lookup key <$> readIORef ref+ , sessionEstablish = \key val -> do+ atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)+ , sessionInvalidate = \key -> do+ atomicModifyIORef' ref $ \m -> (M.delete key m, ())+ , sessionUseTicket = False+ }