diff --git a/Benchmarks/Benchmarks.hs b/Benchmarks/Benchmarks.hs deleted file mode 100644 --- a/Benchmarks/Benchmarks.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Connection -import Certificate -import PubKey -import Gauge.Main -import Control.Concurrent.Chan -import Network.TLS -import Network.TLS.Extra.Cipher -import Data.X509 -import Data.X509.Validation -import Data.Default.Class -import Data.IORef - -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 SSL3 blockCipher) small "SSL3-256 bytes" - , benchConnection (getParams TLS10 blockCipher) small "TLS10-256 bytes" - , benchConnection (getParams TLS11 blockCipher) small "TLS11-256 bytes" - , benchConnection (getParams TLS12 blockCipher) small "TLS12-256 bytes" - ] - , bgroup "resumption" - [ benchResumption (getParams SSL3 blockCipher) small "SSL3-256 bytes" - , benchResumption (getParams TLS10 blockCipher) small "TLS10-256 bytes" - , benchResumption (getParams TLS11 blockCipher) small "TLS11-256 bytes" - , 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_AES128GCM_SHA256 - , cipher_DHE_RSA_AES256GCM_SHA384 - , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 - , cipher_DHE_RSA_AES128CCM_SHA256 - , cipher_DHE_RSA_AES128CCM8_SHA256 - , cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 - ] - , benchCiphers "TLS13" TLS13 large - [ cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES256GCM_SHA384 - , cipher_TLS13_CHACHA20POLY1305_SHA256 - , cipher_TLS13_AES128CCM_SHA256 - , cipher_TLS13_AES128CCM8_SHA256 - ] - ] - where - small = B.replicate 256 0 - large = B.replicate 102400 0 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,40 @@ +## Version 2.0.0 + +* `tls` now only supports TLS 1.2 and TLS 1.3 with safe cipher suites. +* Security: BREAKING CHANGE: TLS 1.0 and TLS 1.1 are removed. +* Security: BREAKING CHANGE: all CBC cipher suite are removed. +* Security: BREAKING CHANGE: RC4 and 3DES are removed. +* Security: BREAKING CHANGE: DSS(digital signature standard) is removed. +* Security: BREAKING CHANGE: TLS 1.2 servers require + EMS(extended main secret) by default. + `supportedExtendedMasterSec` is renamed to + `supportedExtendedMainSecret`. +* BREAKING CHANGE: the package is now complied with `Strict` and `StrictData`. +* BREAKING CHANGE: Many data structures are re-defined with + `PatternSynonyms` for extensibility. +* BREAKING CHANGE: the structure of `SessionManager` is changed + to support session tickets. +* API: BREAKING CHANGE: `sendData` can send early data (0-RTT). + `clientEarlyData` is removed. + To send early data via `sendData`, set `clientUseEarlyData` to `True`. + [#466](https://github.com/haskell-tls/hs-tls/issues/466) +* API: `handshake` can receive an alert of client authentication failure + for TLS 1.3. + [#463](https://github.com/haskell-tls/hs-tls/pull/463) +* API: `bye` can receive NewSessionTicket for TLS 1.3. +* Channel binding: `getFinished` and `getPeerFinished` are deprecated. + Use `getTLSUnique` instead. + [#462](https://github.com/haskell-tls/hs-tls/pull/462) +* Channel binding: `getTLSExporter` and `getTLSServerEndPoint` are provided. + [#462](https://github.com/haskell-tls/hs-tls/pull/462) +* Refactoring: the monolithic `handshake` is divided to follow + the diagram of TLS 1.2 and 1.3 for readability. +* Refactoring: test cases are refactored for maintenability + and readablity. `hspec` is used instead of `tasty`. +* Code format: `fourmolu` is used as an official formatter. +* Catching up RFC8446bis-09. + [#467](https://github.com/haskell-tls/hs-tls/issues/467) + ## Version 1.9.0 * BREAKING CHANGE: The type of the `Error_Protocol` constructor of `TLSError` has changed. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -1,194 +1,224 @@ -{-# LANGUAGE CPP #-} -- | --- Module : Network.TLS --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Native Haskell TLS and SSL protocol implementation for server and --- client. +-- Native Haskell TLS protocol implementation for servers and +-- clients. -- -- This provides a high-level implementation of a sensitive security -- protocol, eliminating a common set of security issues through the -- use of the advanced type system, high level constructions and -- common Haskell features. -- --- Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 +-- 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. --- --- Some debug tools linked with tls, are available through the --- http://hackage.haskell.org/package/tls-debug/. - -module Network.TLS - ( +module Network.TLS ( -- * Basic APIs - Context - , contextNew - , handshake - , sendData - , recvData - , bye + Context, + contextNew, + handshake, + sendData, + recvData, + bye, -- * Exceptions -- $exceptions -- * Backend abstraction - , HasBackend(..) - , Backend(..) + HasBackend (..), + Backend (..), -- * Parameters + -- intentionally hide the internal methods even haddock warns. - , TLSParams - , ClientParams(..) - , defaultParamsClient - , ServerParams(..) + TLSParams, + ClientParams (..), + defaultParamsClient, + ServerParams (..), + -- ** Shared - , Shared(..) + Shared (..), + -- ** Hooks - , ClientHooks(..) - , OnCertificateRequest - , OnServerCertificate - , ServerHooks(..) - , Measurement(..) + ClientHooks (..), + OnCertificateRequest, + OnServerCertificate, + ServerHooks (..), + Measurement (..), + -- ** Supported - , Supported(..) + Supported (..), + -- ** Debug parameters - , DebugParams(..) + DebugParams (..), -- * Shared parameters + -- ** Credentials - , Credentials(..) - , Credential - , credentialLoadX509 - , credentialLoadX509FromMemory - , credentialLoadX509Chain - , credentialLoadX509ChainFromMemory + Credentials (..), + Credential, + credentialLoadX509, + credentialLoadX509FromMemory, + credentialLoadX509Chain, + credentialLoadX509ChainFromMemory, + -- ** Session manager - , SessionManager(..) - , noSessionManager - , SessionID - , SessionData(..) - , SessionFlag(..) - , TLS13TicketInfo + SessionManager (..), + noSessionManager, + SessionID, + SessionIDorTicket, + Ticket, + SessionData (..), + SessionFlag (..), + TLS13TicketInfo, + -- ** Validation Cache - , ValidationCache(..) - , ValidationCacheQueryCallback - , ValidationCacheAddCallback - , ValidationCacheResult(..) - , exceptionValidationCache + ValidationCache (..), + ValidationCacheQueryCallback, + ValidationCacheAddCallback, + ValidationCacheResult (..), + exceptionValidationCache, -- * Types + -- ** For 'Supported' - , Version(..) - , Compression(..) - , nullCompression - , HashAndSignatureAlgorithm - , HashAlgorithm(..) - , SignatureAlgorithm(..) - , Group(..) - , EMSMode(..) + Version (..), + Compression (..), + nullCompression, + HashAndSignatureAlgorithm, + supportedSignatureSchemes, + HashAlgorithm (..), + SignatureAlgorithm (..), + Group (..), + supportedNamedGroups, + EMSMode (..), + -- ** For parameters and hooks - , DHParams - , DHPublic - , GroupUsage(..) - , CertificateUsage(..) - , CertificateRejectReason(..) - , CertificateType(..) - , HostName - , MaxFragmentEnum(..) + DHParams, + DHPublic, + GroupUsage (..), + CertificateUsage (..), + CertificateRejectReason (..), + CertificateType (..), + HostName, + MaxFragmentEnum (..), -- * Advanced APIs + -- ** Backend - , ctxConnection - , contextFlush - , contextClose + ctxBackend, + contextFlush, + contextClose, + -- ** Information gathering - , Information(..) - , contextGetInformation - , ClientRandom - , ServerRandom - , unClientRandom - , unServerRandom - , HandshakeMode13(..) - , getClientCertificateChain + Information (..), + contextGetInformation, + ClientRandom, + ServerRandom, + unClientRandom, + unServerRandom, + HandshakeMode13 (..), + getClientCertificateChain, + -- ** Negotiated - , getNegotiatedProtocol - , getClientSNI + getNegotiatedProtocol, + getClientSNI, + -- ** Post-handshake actions - , updateKey - , KeyUpdateRequest(..) - , requestCertificate - , getFinished - , getPeerFinished + updateKey, + KeyUpdateRequest (..), + requestCertificate, + getTLSUnique, + getTLSExporter, + getTLSServerEndPoint, + getFinished, + getPeerFinished, + -- ** Modifying hooks in context - , Hooks(..) - , contextModifyHooks - , Handshake - , contextHookSetHandshakeRecv - , Handshake13 - , contextHookSetHandshake13Recv - , contextHookSetCertificateRecv - , Logging(..) - , Header(..) - , ProtocolType(..) - , contextHookSetLogging + Hooks (..), + contextModifyHooks, + Handshake, + contextHookSetHandshakeRecv, + Handshake13, + contextHookSetHandshake13Recv, + contextHookSetCertificateRecv, + Logging (..), + Header (..), + ProtocolType (..), + contextHookSetLogging, -- * Errors and exceptions + -- ** Errors - , TLSError(..) - , KxError(..) - , AlertDescription(..) + TLSError (..), + KxError (..), + AlertDescription (..), + -- ** Exceptions - , TLSException(..) + TLSException (..), -- * Raw types + -- ** Compressions class - , CompressionC(..) - , CompressionID + CompressionC (..), + CompressionID, + -- ** Crypto Key - , PubKey(..) - , PrivKey(..) + PubKey (..), + PrivKey (..), + -- ** Ciphers & Predefined ciphers - , module Network.TLS.Cipher + module Network.TLS.Cipher, -- * Deprecated - , recvData' - , contextNewOnHandle -#ifdef INCLUDE_NETWORK - , contextNewOnSocket -#endif - , Bytes - , ValidationChecks(..) - , ValidationHooks(..) - ) where + recvData', + Bytes, + ValidationChecks (..), + ValidationHooks (..), +) where -import Network.TLS.Backend (Backend(..), HasBackend(..)) +import Network.TLS.Backend (Backend (..), HasBackend (..)) import Network.TLS.Cipher -import Network.TLS.Compression (CompressionC(..), Compression(..), nullCompression) +import Network.TLS.Compression ( + Compression (..), + CompressionC (..), + nullCompression, + ) import Network.TLS.Context import Network.TLS.Core import Network.TLS.Credentials -import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) -import Network.TLS.Handshake.State (HandshakeMode13(..)) +import Network.TLS.Crypto ( + DHParams, + DHPublic, + Group (..), + KxError (..), + supportedNamedGroups, + ) +import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks import Network.TLS.Measurement import Network.TLS.Parameters import Network.TLS.Session import qualified Network.TLS.State as S -import Network.TLS.Struct ( TLSError(..), TLSException(..) - , HashAndSignatureAlgorithm, HashAlgorithm(..), SignatureAlgorithm(..) - , Header(..), ProtocolType(..), CertificateType(..) - , AlertDescription(..) - , ClientRandom(..), ServerRandom(..) - , Handshake) -import Network.TLS.Struct13 ( Handshake13 ) +import Network.TLS.Struct ( + AlertDescription (..), + CertificateType (..), + ClientRandom (..), + Handshake, + HashAlgorithm (..), + HashAndSignatureAlgorithm, + Header (..), + ProtocolType (..), + ServerRandom (..), + SignatureAlgorithm (..), + TLSError (..), + TLSException (..), + supportedSignatureSchemes, + ) +import Network.TLS.Struct13 (Handshake13) import Network.TLS.Types import Network.TLS.X509 import Data.ByteString as B -import Data.X509 (PubKey(..), PrivKey(..)) +import Data.X509 (PrivKey (..), PubKey (..)) import Data.X509.Validation hiding (HostName) {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-} @@ -202,9 +232,8 @@ getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain -{- $exceptions - Since 1.8.0, this library only throws exceptions of type 'TLSException'. - In the common case where the chosen backend is socket, 'IOException' - may be thrown as well. This happens because the backend for sockets, - opaque to most modules in the @tls@ library, throws those exceptions. --} +-- $exceptions +-- Since 1.8.0, this library only throws exceptions of type 'TLSException'. +-- In the common case where the chosen backend is socket, 'IOException' +-- may be thrown as well. This happens because the backend for sockets, +-- opaque to most modules in the @tls@ library, throws those exceptions. diff --git a/Network/TLS/Backend.hs b/Network/TLS/Backend.hs --- a/Network/TLS/Backend.hs +++ b/Network/TLS/Backend.hs @@ -1,12 +1,4 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Backend --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- A Backend represents a unified way to do IO on different +-- | A Backend represents a unified way to do IO on different -- types without burdening our calling API with multiple -- ways to initialize a new context. -- @@ -15,32 +7,27 @@ -- * a way to write data -- * a way to close the stream -- * a way to flush the stream --- -module Network.TLS.Backend - ( HasBackend(..) - , Backend(..) - ) where +module Network.TLS.Backend ( + HasBackend (..), + Backend (..), +) where -import Network.TLS.Imports import qualified Data.ByteString as B -import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) - -#ifdef INCLUDE_NETWORK -import qualified Network.Socket as Network (Socket, close) +import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network -#endif - -#ifdef INCLUDE_HANS -import qualified Data.ByteString.Lazy as L -import qualified Hans.NetworkStack as Hans -#endif +import Network.TLS.Imports +import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) -- | Connection IO backend data Backend = Backend - { backendFlush :: IO () -- ^ Flush the connection sending buffer, if any. - , backendClose :: IO () -- ^ Close the connection. - , backendSend :: ByteString -> IO () -- ^ Send a bytestring through the connection. - , backendRecv :: Int -> IO ByteString -- ^ Receive specified number of bytes from the connection. + { backendFlush :: IO () + -- ^ Flush the connection sending buffer, if any. + , backendClose :: IO () + -- ^ Close the connection. + , backendSend :: ByteString -> IO () + -- ^ Send a bytestring through the connection. + , backendRecv :: Int -> IO ByteString + -- ^ Receive specified number of bytes from the connection. } class HasBackend a where @@ -51,53 +38,21 @@ initializeBackend _ = return () getBackend = id -#if defined(__GLASGOW_HASKELL__) && WINDOWS --- Socket recv and accept calls on Windows platform cannot be interrupted when compiled with -threaded. --- See https://ghc.haskell.org/trac/ghc/ticket/5797 for details. --- The following enables simple workaround -#define SOCKET_ACCEPT_RECV_WORKAROUND -#endif - safeRecv :: Network.Socket -> Int -> IO ByteString -#ifndef SOCKET_ACCEPT_RECV_WORKAROUND safeRecv = Network.recv -#else -safeRecv s buf = do - var <- newEmptyMVar - forkIO $ Network.recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var - takeMVar var -#endif -#ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll - where recvAll n = B.concat <$> loop n - where loop 0 = return [] - loop left = do - r <- safeRecv sock left - if B.null r - then return [] - else (r:) <$> loop (left - B.length r) -#endif - -#ifdef INCLUDE_HANS -instance HasBackend Hans.Socket where - initializeBackend _ = return () - getBackend sock = Backend (return ()) (Hans.close sock) sendAll recvAll - where sendAll x = do - amt <- fromIntegral <$> Hans.sendBytes sock (L.fromStrict x) - if (amt == 0) || (amt == B.length x) - then return () - else sendAll (B.drop amt x) - recvAll n = loop (fromIntegral n) L.empty - loop 0 acc = return (L.toStrict acc) - loop left acc = do - r <- Hans.recvBytes sock left - if L.null r - then loop 0 acc - else loop (left - L.length r) (acc `L.append` r) -#endif + where + recvAll n = B.concat <$> loop n + where + loop 0 = return [] + loop left = do + r <- safeRecv sock left + if B.null r + then return [] + else (r :) <$> loop (left - B.length r) instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering diff --git a/Network/TLS/Cap.hs b/Network/TLS/Cap.hs deleted file mode 100644 --- a/Network/TLS/Cap.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | --- Module : Network.TLS.Cap --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- - -module Network.TLS.Cap - ( hasHelloExtensions - , hasExplicitBlockIV - ) where - -import Network.TLS.Types - -hasHelloExtensions, hasExplicitBlockIV :: Version -> Bool - -hasHelloExtensions ver = ver >= SSL3 -hasExplicitBlockIV ver = ver >= TLS11 diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -1,38 +1,32 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} --- | --- Module : Network.TLS.Cipher --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Cipher - ( CipherKeyExchangeType(..) - , Bulk(..) - , BulkFunctions(..) - , BulkDirection(..) - , BulkState(..) - , BulkStream(..) - , BulkBlock - , BulkAEAD - , bulkInit - , Hash(..) - , Cipher(..) - , CipherID - , cipherKeyBlockSize - , BulkKey - , BulkIV - , BulkNonce - , BulkAdditionalData - , cipherAllowedForVersion - , hasMAC - , hasRecordIV - ) where +{-# OPTIONS_HADDOCK hide #-} +module Network.TLS.Cipher ( + CipherKeyExchangeType (..), + Bulk (..), + BulkFunctions (..), + BulkDirection (..), + BulkState (..), + BulkStream (..), + BulkBlock, + BulkAEAD, + bulkInit, + Hash (..), + Cipher (..), + CipherID, + cipherKeyBlockSize, + BulkKey, + BulkIV, + BulkNonce, + BulkAdditionalData, + cipherAllowedForVersion, + hasMAC, + hasRecordIV, +) where + import Crypto.Cipher.Types (AuthTag) -import Network.TLS.Types (CipherID, Version(..)) -import Network.TLS.Crypto (Hash(..), hashDigestSize) +import Network.TLS.Crypto (Hash (..), hashDigestSize) +import Network.TLS.Types (CipherID, Version (..)) import qualified Data.ByteString as B @@ -42,101 +36,103 @@ type BulkNonce = B.ByteString type BulkAdditionalData = B.ByteString -data BulkState = - BulkStateStream BulkStream - | BulkStateBlock BulkBlock - | BulkStateAEAD BulkAEAD +data BulkState + = BulkStateStream BulkStream + | BulkStateBlock BulkBlock + | BulkStateAEAD BulkAEAD | BulkStateUninitialized instance Show BulkState where - show (BulkStateStream _) = "BulkStateStream" - show (BulkStateBlock _) = "BulkStateBlock" - show (BulkStateAEAD _) = "BulkStateAEAD" - show BulkStateUninitialized = "BulkStateUninitialized" + show (BulkStateStream _) = "BulkStateStream" + show (BulkStateBlock _) = "BulkStateBlock" + 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) +type BulkAEAD = + BulkNonce -> B.ByteString -> BulkAdditionalData -> (B.ByteString, AuthTag) data BulkDirection = BulkEncrypt | BulkDecrypt - deriving (Show,Eq) + deriving (Show, Eq) bulkInit :: Bulk -> BulkDirection -> BulkKey -> BulkState bulkInit bulk direction key = case bulkF bulk of - BulkBlockF ini -> BulkStateBlock (ini direction key) + BulkBlockF ini -> BulkStateBlock (ini direction key) BulkStreamF ini -> BulkStateStream (ini direction key) - BulkAeadF ini -> BulkStateAEAD (ini direction key) + BulkAeadF ini -> BulkStateAEAD (ini direction key) -data BulkFunctions = - BulkBlockF (BulkDirection -> BulkKey -> BulkBlock) +data BulkFunctions + = BulkBlockF (BulkDirection -> BulkKey -> BulkBlock) | BulkStreamF (BulkDirection -> BulkKey -> BulkStream) - | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) - -hasMAC,hasRecordIV :: BulkFunctions -> Bool + | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) -hasMAC (BulkBlockF _ ) = True +hasMAC, hasRecordIV :: BulkFunctions -> Bool +hasMAC (BulkBlockF _) = True hasMAC (BulkStreamF _) = True -hasMAC (BulkAeadF _ ) = False - +hasMAC (BulkAeadF _) = False hasRecordIV = hasMAC -data CipherKeyExchangeType = - CipherKeyExchange_RSA +data CipherKeyExchangeType + = CipherKeyExchange_RSA | CipherKeyExchange_DH_Anon | CipherKeyExchange_DHE_RSA | CipherKeyExchange_ECDHE_RSA - | CipherKeyExchange_DHE_DSS - | CipherKeyExchange_DH_DSS + | 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) + 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 + { 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 - ] + 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 + { 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 bulk = cipherBulk cipher + where + bulk = cipherBulk cipher -- | Check if a specific 'Cipher' is allowed to be used -- with the version specified cipherAllowedForVersion :: Version -> Cipher -> Bool cipherAllowedForVersion ver cipher = case cipherMinVer cipher of - Nothing -> ver < TLS13 + Nothing -> ver < TLS13 Just cVer -> cVer <= ver && (ver < TLS13 || cVer >= TLS13) instance Show Cipher where diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -1,40 +1,34 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} --- | --- Module : Network.TLS.Compression --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Compression - ( CompressionC(..) - , Compression(..) - , CompressionID - , nullCompression - , NullCompression +{-# OPTIONS_HADDOCK hide #-} +module Network.TLS.Compression ( + CompressionC (..), + Compression (..), + CompressionID, + nullCompression, + NullCompression, + -- * member redefined for the class abstraction - , compressionID - , compressionDeflate - , compressionInflate + compressionID, + compressionDeflate, + compressionInflate, -- * helper - , compressionIntersectID - ) where + compressionIntersectID, +) where -import Network.TLS.Types (CompressionID) -import Network.TLS.Imports import Control.Arrow (first) +import Network.TLS.Imports +import Network.TLS.Types (CompressionID) -- | supported compression algorithms need to be part of this class class CompressionC a where - compressionCID :: a -> CompressionID + compressionCID :: a -> CompressionID compressionCDeflate :: a -> ByteString -> (a, ByteString) compressionCInflate :: a -> ByteString -> (a, ByteString) -- | every compression need to be wrapped in this, to fit in structure -data Compression = forall a . CompressionC a => Compression a +data Compression = forall a. CompressionC a => Compression a -- | return the associated ID for this algorithm compressionID :: Compression -> CompressionID @@ -65,7 +59,7 @@ data NullCompression = NullCompression instance CompressionC NullCompression where - compressionCID _ = 0 + compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b) diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -1,113 +1,115 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Context --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Context - ( +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Context ( -- * Context configuration - TLSParams + TLSParams, -- * Context object and accessor - , Context(..) - , Hooks(..) - , Established(..) - , ctxEOF - , ctxHasSSLv2ClientHello - , ctxDisableSSLv2ClientHello - , ctxEstablished - , withLog - , ctxWithHooks - , contextModifyHooks - , setEOF - , setEstablished - , contextFlush - , contextClose - , contextSend - , contextRecv - , updateMeasure - , withMeasure - , withReadLock - , withWriteLock - , withStateLock - , withRWLock + Context (..), + Hooks (..), + Established (..), + RecordLayer (..), + ctxEOF, + ctxEstablished, + withLog, + ctxWithHooks, + contextModifyHooks, + setEOF, + setEstablished, + contextFlush, + contextClose, + contextSend, + contextRecv, + updateMeasure, + withMeasure, + withReadLock, + withWriteLock, + withStateLock, + withRWLock, -- * information - , Information(..) - , contextGetInformation + Information (..), + contextGetInformation, -- * New contexts - , contextNew - -- * Deprecated new contexts methods - , contextNewOnHandle -#ifdef INCLUDE_NETWORK - , contextNewOnSocket -#endif + contextNew, -- * Context hooks - , contextHookSetHandshakeRecv - , contextHookSetHandshake13Recv - , contextHookSetCertificateRecv - , contextHookSetLogging + contextHookSetHandshakeRecv, + contextHookSetHandshake13Recv, + contextHookSetCertificateRecv, + contextHookSetLogging, -- * Using context states - , throwCore - , usingState - , usingState_ - , runTxState - , runRxState - , usingHState - , getHState - , getStateRNG - , tls13orLater - , getFinished - , getPeerFinished - ) where + throwCore, + usingState, + usingState_, + runTxRecordState, + runRxRecordState, + usingHState, + getHState, + getStateRNG, + tls13orLater, + getTLSUnique, + getTLSExporter, + getTLSServerEndPoint, + getFinished, + getPeerFinished, + TLS13State (..), + getTLS13State, + modifyTLS13State, +) where +import Control.Concurrent.MVar +import Control.Monad.State.Strict +import Data.IORef + import Network.TLS.Backend +import Network.TLS.Cipher import Network.TLS.Context.Internal -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.State +import Network.TLS.Crypto +import Network.TLS.Handshake ( + handshakeClient, + handshakeClientWith, + handshakeServer, + handshakeServerWith, + ) +import Network.TLS.Handshake.State13 import Network.TLS.Hooks -import Network.TLS.Record.State -import Network.TLS.Record.Layer +import Network.TLS.Imports +import Network.TLS.KeySchedule +import Network.TLS.Measurement +import Network.TLS.Packet +import Network.TLS.Parameters +import Network.TLS.PostHandshake ( + postHandshakeAuthClientWith, + postHandshakeAuthServerWith, + requestCertificateServer, + ) +import Network.TLS.RNG import Network.TLS.Record.Reading +import Network.TLS.Record.State import Network.TLS.Record.Writing -import Network.TLS.Parameters -import Network.TLS.Measurement -import Network.TLS.Types (Role(..)) -import Network.TLS.Handshake (handshakeClient, handshakeClientWith, handshakeServer, handshakeServerWith) -import Network.TLS.PostHandshake (requestCertificateServer, postHandshakeAuthClientWith, postHandshakeAuthServerWith) +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types (Role (..)) import Network.TLS.X509 -import Network.TLS.RNG -import Control.Concurrent.MVar -import Control.Monad.State.Strict -import Data.IORef - --- deprecated imports -#ifdef INCLUDE_NETWORK -import Network.Socket (Socket) -#endif -import System.IO (Handle) - class TLSParams a where getTLSCommonParams :: a -> CommonParams - getTLSRole :: a -> Role - doHandshake :: a -> Context -> IO () - doHandshakeWith :: a -> Context -> Handshake -> IO () + getTLSRole :: a -> Role + doHandshake :: a -> Context -> IO () + doHandshakeWith :: a -> Context -> Handshake -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () instance TLSParams ClientParams where - getTLSCommonParams cparams = ( clientSupported cparams - , clientShared cparams - , clientDebug cparams - ) + getTLSCommonParams cparams = + ( clientSupported cparams + , clientShared cparams + , clientDebug cparams + ) getTLSRole _ = ClientRole doHandshake = handshakeClient doHandshakeWith = handshakeClientWith @@ -115,10 +117,11 @@ doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where - getTLSCommonParams sparams = ( serverSupported sparams - , serverShared sparams - , serverDebug sparams - ) + getTLSCommonParams sparams = + ( serverSupported sparams + , serverShared sparams + , serverDebug sparams + ) getTLSRole _ = ServerRole doHandshake = handshakeServer doHandshakeWith = handshakeServerWith @@ -126,127 +129,164 @@ doPostHandshakeAuthWith = postHandshakeAuthServerWith -- | create a new context using the backend and parameters specified. -contextNew :: (MonadIO m, HasBackend backend, TLSParams params) - => backend -- ^ Backend abstraction with specific method to interact with the connection type. - -> params -- ^ Parameters of the context. - -> m Context +contextNew + :: (MonadIO m, HasBackend backend, TLSParams params) + => backend + -- ^ Backend abstraction with specific method to interact with the connection type. + -> params + -- ^ Parameters of the context. + -> m Context contextNew backend params = liftIO $ do initializeBackend backend let (supported, shared, debug) = getTLSCommonParams params seed <- case debugSeed debug of - Nothing -> do seed <- seedNew - debugPrintSeed debug seed - return seed - Just determ -> return determ + Nothing -> do + seed <- seedNew + debugPrintSeed debug seed + return seed + Just determ -> return determ let rng = newStateRNG seed let role = getTLSRole params - st = newTLSState rng role + st = newTLSState rng role - stvar <- newMVar st - eof <- newIORef False + tlsstate <- newMVar st + eof <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement - -- we enable the reception of SSLv2 ClientHello message only in the - -- server context, where we might be dealing with an old/compat client. - sslv2Compat <- newIORef (role == ServerRole) needEmptyPacket <- newIORef False hooks <- newIORef defaultHooks - tx <- newMVar newRecordState - rx <- newMVar newRecordState - hs <- newMVar Nothing - as <- newIORef [] - crs <- newIORef [] - lockWrite <- newMVar () - lockRead <- newMVar () - lockState <- newMVar () - finished <- newIORef Nothing - peerFinished <- newIORef Nothing + tx <- newMVar newRecordState + rx <- newMVar newRecordState + hs <- newMVar Nothing + recvActionsRef <- newIORef [] + sendActionRef <- newIORef Nothing + crs <- newIORef [] + locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () + st13ref <- newIORef defaultTLS13State + let roleParams = + RoleParams + { doHandshake_ = doHandshake params + , doHandshakeWith_ = doHandshakeWith params + , doRequestCertificate_ = doRequestCertificate params + , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params + } - let ctx = Context - { ctxConnection = getBackend backend - , ctxShared = shared - , ctxSupported = supported - , ctxState = stvar - , ctxFragmentSize = Just 16384 - , ctxTxState = tx - , ctxRxState = rx - , ctxHandshake = hs - , ctxDoHandshake = doHandshake params - , ctxDoHandshakeWith = doHandshakeWith params - , ctxDoRequestCertificate = doRequestCertificate params - , ctxDoPostHandshakeAuthWith = doPostHandshakeAuthWith params - , ctxMeasurement = stats - , ctxEOF_ = eof - , ctxEstablished_ = established - , ctxSSLv2ClientHello = sslv2Compat - , ctxNeedEmptyPacket = needEmptyPacket - , ctxHooks = hooks - , ctxLockWrite = lockWrite - , ctxLockRead = lockRead - , ctxLockState = lockState - , ctxPendingActions = as - , ctxCertRequests = crs - , ctxKeyLogger = debugKeyLogger debug - , ctxRecordLayer = recordLayer - , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp - , ctxQUICMode = False - , ctxFinished = finished - , ctxPeerFinished = peerFinished - } + let ctx = + Context + { ctxBackend = getBackend backend + , ctxShared = shared + , ctxSupported = supported + , ctxTLSState = tlsstate + , ctxFragmentSize = Just 16384 + , ctxTxRecordState = tx + , ctxRxRecordState = rx + , ctxHandshakeState = hs + , ctxRoleParams = roleParams + , ctxMeasurement = stats + , ctxEOF_ = eof + , ctxEstablished_ = established + , ctxNeedEmptyPacket = needEmptyPacket + , ctxHooks = hooks + , ctxLocks = locks + , ctxPendingRecvActions = recvActionsRef + , ctxPendingSendAction = sendActionRef + , ctxCertRequests = crs + , ctxKeyLogger = debugKeyLogger debug + , ctxRecordLayer = recordLayer + , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp + , ctxQUICMode = False + , ctxTLS13State = st13ref + } syncNoOp _ _ = return () - recordLayer = RecordLayer - { recordEncode = encodeRecord ctx - , recordEncode13 = encodeRecord13 ctx - , recordSendBytes = sendBytes ctx - , recordRecv = recvRecord ctx - , recordRecv13 = recvRecord13 ctx - } + recordLayer = + RecordLayer + { recordEncode = encodeRecord + , recordEncode13 = encodeRecord13 + , recordSendBytes = sendBytes + , recordRecv = recvRecord + , recordRecv13 = recvRecord13 + } return ctx --- | create a new context on an handle. -contextNewOnHandle :: (MonadIO m, TLSParams params) - => Handle -- ^ Handle of the connection. - -> params -- ^ Parameters of the context. - -> m Context -contextNewOnHandle = contextNew -{-# DEPRECATED contextNewOnHandle "use contextNew" #-} - -#ifdef INCLUDE_NETWORK --- | create a new context on a socket. -contextNewOnSocket :: (MonadIO m, TLSParams params) - => Socket -- ^ Socket of the connection. - -> params -- ^ Parameters of the context. - -> m Context -contextNewOnSocket sock params = contextNew sock params -{-# DEPRECATED contextNewOnSocket "use contextNew" #-} -#endif - contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = - contextModifyHooks context (\hooks -> hooks { hookRecvHandshake = f }) + contextModifyHooks context (\hooks -> hooks{hookRecvHandshake = f}) -contextHookSetHandshake13Recv :: Context -> (Handshake13 -> IO Handshake13) -> IO () +contextHookSetHandshake13Recv + :: Context -> (Handshake13 -> IO Handshake13) -> IO () contextHookSetHandshake13Recv context f = - contextModifyHooks context (\hooks -> hooks { hookRecvHandshake13 = f }) + contextModifyHooks context (\hooks -> hooks{hookRecvHandshake13 = f}) contextHookSetCertificateRecv :: Context -> (CertificateChain -> IO ()) -> IO () contextHookSetCertificateRecv context f = - contextModifyHooks context (\hooks -> hooks { hookRecvCertificates = f }) + contextModifyHooks context (\hooks -> hooks{hookRecvCertificates = f}) contextHookSetLogging :: Context -> Logging -> IO () contextHookSetLogging context loggingCallbacks = - contextModifyHooks context (\hooks -> hooks { hookLogging = loggingCallbacks }) + contextModifyHooks context (\hooks -> hooks{hookLogging = loggingCallbacks}) --- | Get TLS Finished sent to peer -getFinished :: Context -> IO (Maybe FinishedData) -getFinished = readIORef . ctxFinished +{-# DEPRECATED getFinished "Use getTLSUnique instead" #-} --- | Get TLS Finished received from peer -getPeerFinished :: Context -> IO (Maybe FinishedData) -getPeerFinished = readIORef . ctxPeerFinished +-- | Getting TLS Finished sent to peer. +getFinished :: Context -> IO (Maybe VerifyData) +getFinished ctx = usingState_ ctx getMyVerifyData + +{-# DEPRECATED getPeerFinished "Use getTLSUnique instead" #-} + +-- | Getting TLS Finished received from peer. +getPeerFinished :: Context -> IO (Maybe VerifyData) +getPeerFinished ctx = usingState_ ctx getPeerVerifyData + +-- | Getting the "tls-unique" channel binding for TLS 1.2 (RFC5929). +-- For TLS 1.3, 'Nothing' is returned. +-- 'supportedExtendedMainSecret' must be 'RequireEMS' +-- But in general, it is highly recommended to upgrade to TLS 1.3 +-- and use the "tls-exporter" channel binding via 'getTLSExporter'. +getTLSUnique :: Context -> IO (Maybe ByteString) +getTLSUnique ctx = do + ver <- liftIO $ usingState_ ctx getVersion + if ver == TLS12 + then usingState_ ctx getFirstVerifyData + else return Nothing + +-- | Getting the "tls-exporter" channel binding for TLS 1.3 (RFC9266). +-- For TLS 1.2, 'Nothing' is returned. +getTLSExporter :: Context -> IO (Maybe ByteString) +getTLSExporter ctx = do + ver <- liftIO $ usingState_ ctx getVersion + if ver == TLS13 + then exporter ctx "EXPORTER-Channel-Binding" "" 32 + else return Nothing + +exporter :: Context -> ByteString -> ByteString -> Int -> IO (Maybe ByteString) +exporter ctx label context outlen = do + msecret <- usingState_ ctx getExporterSecret + mcipher <- failOnEitherError $ runRxRecordState ctx $ gets stCipher + return $ case (msecret, mcipher) of + (Just secret, Just cipher) -> + let h = cipherHash cipher + secret' = deriveSecret h secret label "" + label' = "exporter" + value' = hash h context + key = hkdfExpandLabel h secret' label' value' outlen + in Just key + _ -> Nothing + +-- | Getting the "tls-server-end-point" channel binding for TLS 1.2 +-- (RFC5929). For 1.3, there is no specifications for how to create +-- it. In this implementation, a certificate chain without +-- extensions is hashed like TLS 1.2. +getTLSServerEndPoint :: Context -> IO (Maybe ByteString) +getTLSServerEndPoint ctx = do + mcc <- usingState_ ctx getServerCertificateChain + case mcc of + Nothing -> return Nothing + Just cc -> do + (usedHash, _, _, _) <- getRxRecordState ctx + return $ Just $ hash usedHash $ encodeCertificate cc diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -1,78 +1,87 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} --- | --- Module : Network.TLS.Context.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Context.Internal - ( + +module Network.TLS.Context.Internal ( -- * Context configuration - ClientParams(..) - , ServerParams(..) - , defaultParamsClient - , SessionID - , SessionData(..) - , MaxFragmentEnum(..) - , Measurement(..) + ClientParams (..), + ServerParams (..), + defaultParamsClient, + SessionID, + SessionData (..), + MaxFragmentEnum (..), + Measurement (..), -- * Context object and accessor - , Context(..) - , Hooks(..) - , Established(..) - , PendingAction(..) - , ctxEOF - , ctxHasSSLv2ClientHello - , ctxDisableSSLv2ClientHello - , ctxEstablished - , withLog - , ctxWithHooks - , contextModifyHooks - , setEOF - , setEstablished - , contextFlush - , contextClose - , contextSend - , contextRecv - , updateRecordLayer - , updateMeasure - , withMeasure - , withReadLock - , withWriteLock - , withStateLock - , withRWLock + Context (..), + Hooks (..), + Established (..), + PendingRecvAction (..), + RecordLayer (..), + Locks (..), + RoleParams (..), + ctxEOF, + ctxEstablished, + withLog, + ctxWithHooks, + contextModifyHooks, + setEOF, + setEstablished, + contextFlush, + contextClose, + contextSend, + contextRecv, + updateRecordLayer, + updateMeasure, + withMeasure, + withReadLock, + withWriteLock, + withStateLock, + withRWLock, -- * information - , Information(..) - , contextGetInformation + Information (..), + contextGetInformation, -- * Using context states - , throwCore - , failOnEitherError - , usingState - , usingState_ - , runTxState - , runRxState - , usingHState - , getHState - , saveHState - , restoreHState - , getStateRNG - , tls13orLater - , addCertRequest13 - , getCertRequest13 - , decideRecordVersion + throwCore, + failOnEitherError, + usingState, + usingState_, + runTxRecordState, + runRxRecordState, + usingHState, + getHState, + saveHState, + restoreHState, + getStateRNG, + tls13orLater, + addCertRequest13, + getCertRequest13, + decideRecordVersion, -- * Misc - , HandshakeSync(..) - ) where + HandshakeSync (..), + TLS13State (..), + defaultTLS13State, + getTLS13State, + modifyTLS13State, + CipherChoice (..), + makeCipherChoice, +) where +import Control.Concurrent.MVar +import Control.Exception (throwIO) +import Control.Monad.State.Strict +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 import Network.TLS.Handshake.State @@ -80,7 +89,7 @@ import Network.TLS.Imports import Network.TLS.Measurement import Network.TLS.Parameters -import Network.TLS.Record.Layer +import Network.TLS.Record import Network.TLS.Record.State import Network.TLS.State import Network.TLS.Struct @@ -88,81 +97,171 @@ import Network.TLS.Types import Network.TLS.Util -import Control.Concurrent.MVar -import Control.Exception (throwIO) -import Control.Monad.State.Strict -import qualified Data.ByteString as B -import Data.IORef -import Data.Tuple - -- | Information related to a running context, e.g. current cipher data Information = Information - { infoVersion :: Version - , infoCipher :: Cipher - , infoCompression :: Compression - , infoMasterSecret :: Maybe ByteString - , infoExtendedMasterSec :: Bool + { infoVersion :: Version + , infoCipher :: Cipher + , infoCompression :: Compression + , infoMainSecret :: Maybe ByteString + , infoExtendedMainSecret :: Bool , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom - , infoNegotiatedGroup :: Maybe Group - , infoTLS13HandshakeMode :: Maybe HandshakeMode13 + , infoSupportedGroup :: Maybe Group + , infoTLS12Resumption :: Bool + , infoTLS13HandshakeMode :: Maybe HandshakeMode13 , infoIsEarlyDataAccepted :: Bool - } deriving (Show,Eq) + } + deriving (Show, Eq) -- | A TLS Context keep tls specific state, parameters and backend information. -data Context = forall bytes . Monoid bytes => Context - { ctxConnection :: Backend -- ^ return the backend object associated with this context - , ctxSupported :: Supported - , ctxShared :: Shared - , ctxState :: MVar TLSState - , ctxMeasurement :: IORef Measurement - , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. - , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. - , ctxNeedEmptyPacket :: IORef Bool -- ^ empty packet workaround for CBC guessability. - , ctxSSLv2ClientHello :: IORef Bool -- ^ enable the reception of compatibility SSLv2 client hello. - -- the flag will be set to false regardless of its initial value - -- after the first packet received. - , ctxFragmentSize :: Maybe Int -- ^ maximum size of plaintext fragments - , ctxTxState :: MVar RecordState -- ^ current tx state - , ctxRxState :: MVar RecordState -- ^ current rx state - , ctxHandshake :: MVar (Maybe HandshakeState) -- ^ optional handshake state - , ctxDoHandshake :: Context -> IO () - , ctxDoHandshakeWith :: Context -> Handshake -> IO () - , ctxDoRequestCertificate :: Context -> IO Bool - , ctxDoPostHandshakeAuthWith :: Context -> Handshake13 -> IO () - , ctxHooks :: IORef Hooks -- ^ hooks for this context - , ctxLockWrite :: MVar () -- ^ lock to use for writing data (including updating the state) - , ctxLockRead :: MVar () -- ^ lock to use for reading data (including updating the state) - , ctxLockState :: MVar () -- ^ lock used during read/write when receiving and sending packet. - -- it is usually nested in a write or read lock. - , ctxPendingActions :: IORef [PendingAction] - , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests - , ctxKeyLogger :: String -> IO () - , ctxRecordLayer :: RecordLayer bytes - , ctxHandshakeSync :: HandshakeSync - , ctxQUICMode :: Bool - , ctxFinished :: IORef (Maybe FinishedData) - , ctxPeerFinished :: IORef (Maybe FinishedData) +data Context = forall a. + Monoid a => + Context + { ctxBackend :: Backend + -- ^ return the backend object associated with this context + , ctxSupported :: Supported + , ctxShared :: Shared + , ctxTLSState :: MVar TLSState + , ctxMeasurement :: IORef Measurement + , ctxEOF_ :: IORef Bool + -- ^ has the handle EOFed or not. + , ctxEstablished_ :: IORef Established + -- ^ has the handshake been done and been successful. + , ctxTxRecordState :: MVar RecordState + -- ^ current TX record state + , ctxRxRecordState :: MVar RecordState + -- ^ current RX record state + , ctxHandshakeState :: MVar (Maybe HandshakeState) + -- ^ optional handshake state + , 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 + , ctxHandshakeSync :: HandshakeSync + , ctxQUICMode :: Bool + , -- Misc + ctxNeedEmptyPacket :: IORef Bool + -- ^ empty packet workaround for CBC guessability. + , ctxFragmentSize :: Maybe Int + -- ^ maximum size of plaintext fragments } -data HandshakeSync = HandshakeSync (Context -> ClientState -> IO ()) - (Context -> ServerState -> IO ()) +data RoleParams = RoleParams + { doHandshake_ :: Context -> IO () + , doHandshakeWith_ :: Context -> Handshake -> IO () + , doRequestCertificate_ :: Context -> IO Bool + , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () + } -updateRecordLayer :: Monoid bytes => RecordLayer bytes -> Context -> Context +data Locks = Locks + { lockWrite :: MVar () + -- ^ lock to use for writing data (including updating the state) + , lockRead :: MVar () + -- ^ lock to use for reading data (including updating the state) + , lockState :: MVar () + -- ^ lock used during read/write when receiving and sending packet. + -- it is usually nested in a write or read lock. + } + +data CipherChoice = CipherChoice + { cVersion :: Version + , cCipher :: Cipher + , cHash :: Hash + , cZero :: ByteString + } + +makeCipherChoice :: Version -> Cipher -> CipherChoice +makeCipherChoice ver cipher = CipherChoice ver cipher h zero + where + h = cipherHash cipher + zero = B.replicate (hashDigestSize h) 0 + +data TLS13State = TLS13State + { tls13stRecvNST :: Bool -- client + , tls13stSentClientCert :: Bool -- client + , tls13stRecvSF :: Bool -- client + , tls13stSentCF :: Bool -- client + , tls13stRecvCF :: Bool -- server + , tls13stPendingRecvData :: Maybe ByteString -- client + , tls13stPendingSentData :: [ByteString] -> [ByteString] -- client + , tls13stRTT :: Millisecond + , tls13st0RTTAccepted :: Bool -- client + , tls13stClientExtensions :: [ExtensionRaw] -- client + , tls13stChoice :: ~CipherChoice -- client + , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client + , tls13stSession :: Session + , tls13stSentExtensions :: [ExtensionID] + } + +defaultTLS13State :: TLS13State +defaultTLS13State = + TLS13State + { tls13stRecvNST = False + , tls13stSentClientCert = False + , tls13stRecvSF = False + , tls13stSentCF = False + , tls13stRecvCF = False + , tls13stPendingRecvData = Nothing + , tls13stPendingSentData = id + , tls13stRTT = 0 + , tls13st0RTTAccepted = False + , tls13stClientExtensions = [] + , tls13stChoice = undefined + , tls13stHsKey = Nothing + , tls13stSession = Session Nothing + , tls13stSentExtensions = [] + } + +getTLS13State :: Context -> IO TLS13State +getTLS13State Context{..} = readIORef ctxTLS13State + +modifyTLS13State :: Context -> (TLS13State -> TLS13State) -> IO () +modifyTLS13State Context{..} f = atomicModifyIORef' ctxTLS13State $ \st -> (f st, ()) + +data HandshakeSync + = HandshakeSync + (Context -> ClientState -> IO ()) + (Context -> ServerState -> IO ()) + +{- FOURMOLU_DISABLE -} +data RecordLayer a = RecordLayer + { -- Writing.hs + recordEncode :: 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)) + , recordRecv13 :: Context -> IO (Either TLSError (Record Plaintext)) + } +{- FOURMOLU_ENABLE -} + +updateRecordLayer :: Monoid a => RecordLayer a -> Context -> Context updateRecordLayer recordLayer Context{..} = - Context { ctxRecordLayer = recordLayer, .. } + Context{ctxRecordLayer = recordLayer, ..} -data Established = NotEstablished - | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed - | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip - | Established - deriving (Eq, Show) +data Established + = NotEstablished + | EarlyDataAllowed Int -- server: remaining 0-RTT bytes allowed + | EarlyDataNotAllowed Int -- sever: remaining 0-RTT packets allowed to skip + | EarlyDataSending + | Established + deriving (Eq, Show) -data PendingAction - = PendingAction Bool (Handshake13 -> IO ()) - -- ^ simple pending action - | PendingActionHash Bool (ByteString -> Handshake13 -> IO ()) - -- ^ pending action taking transcript hash up to preceding message +data PendingRecvAction + = -- | simple pending action. The first 'Bool' is necessity of alignment. + PendingRecvAction Bool (Handshake13 -> IO ()) + | -- | pending action taking transcript hash up to preceding message + -- The first 'Bool' is necessity of alignment. + PendingRecvActionHash Bool (ByteString -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) @@ -170,51 +269,53 @@ withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f --- | A shortcut for 'backendFlush . ctxConnection'. +-- | A shortcut for 'backendFlush . ctxBackend'. contextFlush :: Context -> IO () -contextFlush = backendFlush . ctxConnection +contextFlush = backendFlush . ctxBackend --- | A shortcut for 'backendClose . ctxConnection'. +-- | A shortcut for 'backendClose . ctxBackend'. contextClose :: Context -> IO () -contextClose = backendClose . ctxConnection +contextClose = backendClose . ctxBackend -- | Information about the current context contextGetInformation :: Context -> IO (Maybe Information) contextGetInformation ctx = do - ver <- usingState_ ctx $ gets stVersion + ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx let (ms, ems, cr, sr, hm13, grp) = case hstate of - Just st -> (hstMasterSecret st, - hstExtendedMasterSec st, - Just (hstClientRandom st), - hstServerRandom st, - if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing, - hstNegotiatedGroup st) + Just st -> + ( hstMainSecret st + , hstExtendedMainSecret st + , Just (hstClientRandom st) + , hstServerRandom st + , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing + , hstSupportedGroup st + ) Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) - (cipher,comp) <- readMVar (ctxRxState ctx) <&> \st -> (stCipher st, stCompression st) + (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 case (ver, cipher) of - (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted - _ -> return Nothing + (Just v, Just c) -> + return $ + Just $ + Information v c comp ms ems cr sr grp tls12resumption hm13 accepted + _ -> return Nothing contextSend :: Context -> ByteString -> IO () -contextSend c b = updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxConnection c) b +contextSend c b = + updateMeasure c (addBytesSent $ B.length b) >> (backendSend $ ctxBackend c) b contextRecv :: Context -> Int -> IO ByteString -contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz +contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxBackend c) sz ctxEOF :: Context -> IO Bool ctxEOF ctx = readIORef $ ctxEOF_ ctx -ctxHasSSLv2ClientHello :: Context -> IO Bool -ctxHasSSLv2ClientHello ctx = readIORef $ ctxSSLv2ClientHello ctx - -ctxDisableSSLv2ClientHello :: Context -> IO () -ctxDisableSSLv2ClientHello ctx = writeIORef (ctxSSLv2ClientHello ctx) False - setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True @@ -241,33 +342,33 @@ ret <- f case ret of Left err -> throwCore err - Right r -> return r + Right r -> return r usingState :: Context -> TLSSt a -> IO (Either TLSError a) usingState ctx f = - modifyMVar (ctxState ctx) $ \st -> - let (a, newst) = runTLSState f st - in newst `seq` return (newst, a) + modifyMVar (ctxTLSState ctx) $ \st -> + let (a, newst) = runTLSState f st + in newst `seq` return (newst, a) usingState_ :: Context -> TLSSt a -> IO a usingState_ ctx f = failOnEitherError $ usingState ctx f usingHState :: MonadIO m => Context -> HandshakeM a -> m a -usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> - case mst of - Nothing -> liftIO $ throwIO $ MissingHandshake - Just st -> return $ swap (Just <$> runHandshake st f) +usingHState ctx f = liftIO $ modifyMVar (ctxHandshakeState ctx) $ \case + Nothing -> liftIO $ throwIO MissingHandshake + Just st -> return $ swap (Just <$> runHandshake st f) getHState :: MonadIO m => Context -> m (Maybe HandshakeState) -getHState ctx = liftIO $ readMVar (ctxHandshake ctx) +getHState ctx = liftIO $ readMVar (ctxHandshakeState ctx) saveHState :: Context -> IO (Saved (Maybe HandshakeState)) -saveHState ctx = saveMVar (ctxHandshake ctx) +saveHState ctx = saveMVar (ctxHandshakeState ctx) -restoreHState :: Context - -> Saved (Maybe HandshakeState) - -> IO (Saved (Maybe HandshakeState)) -restoreHState ctx = restoreMVar (ctxHandshake ctx) +restoreHState + :: Context + -> Saved (Maybe HandshakeState) + -> IO (Saved (Maybe HandshakeState)) +restoreHState ctx = restoreMVar (ctxHandshakeState ctx) decideRecordVersion :: Context -> IO (Version, Bool) decideRecordVersion ctx = usingState_ ctx $ do @@ -277,63 +378,73 @@ -- The record version of the first ClientHello SHOULD be TLS 1.0. -- The record version of the second ClientHello MUST be TLS 1.2. let ver' - | ver >= TLS13 = if hrr then TLS12 else TLS10 - | otherwise = ver + | ver >= TLS13 = if hrr then TLS12 else TLS10 + | otherwise = ver return (ver', ver >= TLS13) -runTxState :: Context -> RecordM a -> IO (Either TLSError a) -runTxState ctx f = do +runTxRecordState :: Context -> RecordM a -> IO (Either TLSError a) +runTxRecordState ctx f = do (ver, tls13) <- decideRecordVersion ctx - let opt = RecordOptions { recordVersion = ver - , recordTLS13 = tls13 - } - modifyMVar (ctxTxState ctx) $ \st -> + let opt = + RecordOptions + { recordVersion = ver + , recordTLS13 = tls13 + } + modifyMVar (ctxTxRecordState ctx) $ \st -> case runRecordM f opt st of - Left err -> return (st, Left err) + Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) -runRxState :: Context -> RecordM a -> IO (Either TLSError a) -runRxState ctx f = do - ver <- usingState_ ctx getVersion +runRxRecordState :: Context -> RecordM a -> IO (Either TLSError a) +runRxRecordState ctx f = do + ver <- + usingState_ + ctx + (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) -- For 1.3, ver is just ignored. So, it is not necessary to convert ver. - let opt = RecordOptions { recordVersion = ver - , recordTLS13 = ver >= TLS13 - } - modifyMVar (ctxRxState ctx) $ \st -> + let opt = + RecordOptions + { recordVersion = ver + , recordTLS13 = ver >= TLS13 + } + modifyMVar (ctxRxRecordState ctx) $ \st -> case runRecordM f opt st of - Left err -> return (st, Left err) + Left err -> return (st, Left err) Right (a, newSt) -> return (newSt, Right a) getStateRNG :: Context -> Int -> IO ByteString getStateRNG ctx n = usingState_ ctx $ genRandom n withReadLock :: Context -> IO a -> IO a -withReadLock ctx f = withMVar (ctxLockRead ctx) (const f) +withReadLock ctx f = withMVar (lockRead $ ctxLocks ctx) (const f) withWriteLock :: Context -> IO a -> IO a -withWriteLock ctx f = withMVar (ctxLockWrite ctx) (const f) +withWriteLock ctx f = withMVar (lockWrite $ ctxLocks ctx) (const f) withRWLock :: Context -> IO a -> IO a withRWLock ctx f = withReadLock ctx $ withWriteLock ctx f withStateLock :: Context -> IO a -> IO a -withStateLock ctx f = withMVar (ctxLockState ctx) (const f) +withStateLock ctx f = withMVar (lockState $ ctxLocks ctx) (const f) tls13orLater :: MonadIO m => Context -> m Bool tls13orLater ctx = do - ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme + ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS12 return $ case ev of - Left _ -> False - Right v -> v >= TLS13 + Left _ -> False + Right v -> v >= TLS13 addCertRequest13 :: Context -> Handshake13 -> IO () -addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq:) +addCertRequest13 ctx certReq = modifyIORef (ctxCertRequests ctx) (certReq :) getCertRequest13 :: Context -> CertReqContext -> IO (Maybe Handshake13) getCertRequest13 ctx context = do let ref = ctxCertRequests ctx l <- readIORef ref - let (matched, others) = partition (\(CertRequest13 c _) -> context == c) l + let (matched, others) = partition (\cr -> context == fromCertRequest13 cr) l case matched of - [] -> return Nothing - (certReq:_) -> writeIORef ref others >> return (Just certReq) + [] -> return Nothing + (certReq : _) -> writeIORef ref others >> return (Just certReq) + where + fromCertRequest13 (CertRequest13 c _) = c + fromCertRequest13 _ = error "fromCertRequest13" diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -1,66 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, BangPatterns #-} --- | --- Module : Network.TLS.Core --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Core - ( + +module Network.TLS.Core ( -- * Internal packet sending and receiving - sendPacket - , recvPacket + sendPacket12, + recvPacket12, -- * Initialisation and Termination of context - , bye - , handshake + bye, + handshake, -- * Application Layer Protocol Negotiation - , getNegotiatedProtocol + getNegotiatedProtocol, -- * Server Name Indication - , getClientSNI + getClientSNI, -- * High level API - , sendData - , recvData - , recvData' - , updateKey - , KeyUpdateRequest(..) - , requestCertificate - ) where + sendData, + recvData, + recvData', + updateKey, + KeyUpdateRequest (..), + requestCertificate, +) 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 +import qualified Data.ByteString.Lazy as L +import Data.IORef +import System.Timeout + import Network.TLS.Cipher import Network.TLS.Context import Network.TLS.Crypto -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.State (getSession) -import Network.TLS.Parameters -import Network.TLS.IO -import Network.TLS.Session +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.State import Network.TLS.Handshake.State13 -import Network.TLS.PostHandshake +import Network.TLS.IO import Network.TLS.KeySchedule -import Network.TLS.Types (Role(..), HostName, AnyTrafficSecret(..), ApplicationSecret) -import Network.TLS.Util (catchException, mapChunks_) -import Network.TLS.Extension +import Network.TLS.Parameters +import Network.TLS.PostHandshake +import Network.TLS.Session +import Network.TLS.State (getRole, getSession) import qualified Network.TLS.State as S -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as L -import Control.Monad (unless, when) -import qualified Control.Exception as E +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types ( + AnyTrafficSecret (..), + ApplicationSecret, + HostName, + Role (..), + ) +import Network.TLS.Util (catchException, mapChunks_) -import Control.Monad.State.Strict +-- | Handshake for a new TLS connection +-- This is to be called at the beginning of a connection, and during renegotiation +handshake :: MonadIO m => Context -> m () +handshake ctx = do + handshake_ ctx + -- Trying to receive an alert of client authentication failure + liftIO $ do + tls13 <- tls13orLater ctx + sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx + when (tls13 && sentClientCert) $ do + rtt <- getRTT ctx + mdat <- timeout rtt $ recvData ctx + case mdat of + Nothing -> return () + Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat} +rttFactor :: Int +rttFactor = 3 + +getRTT :: Context -> IO Int +getRTT ctx = do + rtt <- tls13stRTT <$> getTLS13State ctx + return (fromIntegral 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 -- the session might not be resumable (for version < TLS1.2). @@ -68,16 +93,39 @@ -- this doesn't actually close the handle bye :: MonadIO m => Context -> m () bye ctx = liftIO $ do + eof <- ctxEOF ctx + tls13 <- tls13orLater ctx + when (tls13 && not eof) $ do + role <- usingState_ ctx getRole + if role == ClientRole + then do + withWriteLock ctx $ sendCFifNecessary ctx + -- receiving NewSessionTicket + recvNST <- tls13stRecvNST <$> getTLS13State ctx + unless recvNST $ do + rtt <- getRTT ctx + void $ timeout rtt $ recvData ctx + else do + -- receiving Client Finished + recvCF <- tls13stRecvCF <$> getTLS13State ctx + unless recvCF $ do + -- no chance to measure RTT before receiving CF + -- fixme: 1sec is good enough? + void $ timeout 1000000 $ recvData ctx + bye_ ctx + +bye_ :: MonadIO m => Context -> m () +bye_ ctx = liftIO $ do -- Although setEOF is always protected by the read lock, here we don't try -- to wrap ctxEOF with it, so that function bye can still be called -- concurrently to a blocked recvData. eof <- ctxEOF ctx tls13 <- tls13orLater ctx - unless eof $ withWriteLock ctx $ - if tls13 then - sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)] - else - sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] + unless eof $ + withWriteLock ctx $ + if tls13 + then sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)] + else sendPacket12 ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. @@ -89,14 +137,34 @@ getClientSNI :: MonadIO m => Context -> m (Maybe HostName) getClientSNI ctx = liftIO $ usingState_ ctx S.getClientSNI +sendCFifNecessary :: Context -> IO () +sendCFifNecessary ctx = do + st <- getTLS13State ctx + let recvSF = tls13stRecvSF st + sentCF = tls13stSentCF st + when (recvSF && not sentCF) $ do + msend <- readIORef (ctxPendingSendAction ctx) + case msend of + Nothing -> return () + Just sendAction -> do + sendAction ctx + writeIORef (ctxPendingSendAction ctx) Nothing + -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => Context -> L.ByteString -> m () +sendData _ "" = return () sendData ctx dataToSend = liftIO $ do tls13 <- tls13orLater ctx - let sendP - | tls13 = sendPacket13 ctx . AppData13 - | otherwise = sendPacket ctx . AppData + sentCF <- tls13stSentCF <$> getTLS13State ctx + let sendP bs + | tls13 = do + sendPacket13 ctx $ AppData13 bs + unless sentCF $ + modifyTLS13State ctx $ + \st -> st{tls13stPendingSentData = tls13stPendingSentData st . (bs :)} + | otherwise = sendPacket12 ctx $ AppData bs + when tls13 $ withWriteLock ctx $ sendCFifNecessary ctx withWriteLock ctx $ do checkValid ctx -- All chunks are protected with the same write lock because we don't @@ -116,207 +184,257 @@ -- packet, because don't want another thread to receive a new packet -- before this one has been fully processed. -- - -- Even when recvData1/recvData13 loops, we only need to call function + -- Even when recvData12/recvData13 loops, we only need to call function -- checkValid once. Since we hold the read lock, no concurrent call -- will impact the validity of the context. - if tls13 then recvData13 ctx else recvData1 ctx + if tls13 then recvData13 ctx else recvData12 ctx -recvData1 :: Context -> IO B.ByteString -recvData1 ctx = do - pkt <- recvPacket ctx +recvData12 :: Context -> IO B.ByteString +recvData12 ctx = do + pkt <- recvPacket12 ctx either (onError terminate) process pkt - where process (Handshake [ch@ClientHello{}]) = - handshakeWith ctx ch >> recvData1 ctx - process (Handshake [hr@HelloRequest]) = - handshakeWith ctx hr >> recvData1 ctx - - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty - process (Alert [(AlertLevel_Fatal, desc)]) = do - setEOF ctx - E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc)) + where + process (Handshake [ch@ClientHello{}]) = + handshakeWith ctx ch >> recvData12 ctx + process (Handshake [hr@HelloRequest]) = + handshakeWith ctx hr >> 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 + process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty + process (Alert [(AlertLevel_Fatal, desc)]) = do + setEOF ctx + E.throwIO + ( Terminated + True + ("received fatal error: " ++ show desc) + (Error_Protocol "remote side fatal error" desc) + ) - -- when receiving empty appdata, we just retry to get some data. - process (AppData "") = recvData1 ctx - process (AppData x) = return x - process p = let reason = "unexpected message " ++ show p in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + -- when receiving empty appdata, we just retry to get some data. + process (AppData "") = recvData12 ctx + process (AppData x) = return x + process p = + let reason = "unexpected message " ++ show p + in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - terminate = terminateWithWriteLock ctx (sendPacket ctx . Alert) + terminate = terminateWithWriteLock ctx (sendPacket12 ctx . Alert) recvData13 :: Context -> IO B.ByteString recvData13 ctx = do - pkt <- recvPacket13 ctx - either (onError terminate) process pkt - where process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty - process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty - process (Alert13 [(AlertLevel_Fatal, desc)]) = do - setEOF ctx - E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc)) - process (Handshake13 hs) = do - loopHandshake13 hs - recvData13 ctx - -- when receiving empty appdata, we just retry to get some data. - process (AppData13 "") = recvData13 ctx - process (AppData13 x) = do - let chunkLen = C8.length x - established <- ctxEstablished ctx - case established of - EarlyDataAllowed maxSize + mdat <- tls13stPendingRecvData <$> getTLS13State ctx + case mdat of + Nothing -> do + pkt <- recvPacket13 ctx + either (onError terminate) process pkt + Just dat -> do + modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing} + return dat + where + -- UserCanceled MUST be followed by a CloseNotify. + process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty + process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty + process (Alert13 [(AlertLevel_Fatal, desc)]) = do + setEOF ctx + E.throwIO + ( Terminated + True + ("received fatal error: " ++ show desc) + (Error_Protocol "remote side fatal error" desc) + ) + process (Handshake13 hs) = do + loopHandshake13 hs + recvData13 ctx + -- when receiving empty appdata, we just retry to get some data. + process (AppData13 "") = recvData13 ctx + process (AppData13 x) = do + let chunkLen = C8.length x + established <- ctxEstablished ctx + case established of + EarlyDataAllowed maxSize | chunkLen <= maxSize -> do setEstablished ctx $ EarlyDataAllowed (maxSize - chunkLen) return x | otherwise -> - let reason = "early data overflow" in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - EarlyDataNotAllowed n - | n > 0 -> do + let reason = "early data overflow" + in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + EarlyDataNotAllowed n + | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) recvData13 ctx -- ignore "x" | otherwise -> - let reason = "early data deprotect overflow" in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - Established -> return x - NotEstablished -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage - process ChangeCipherSpec13 = do - established <- ctxEstablished ctx - if established /= Established then - recvData13 ctx - else do + let reason = "early data deprotect overflow" + in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + Established -> return x + _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage + process ChangeCipherSpec13 = do + established <- ctxEstablished ctx + if established /= Established + then recvData13 ctx + else do let reason = "CSS after Finished" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - process p = let reason = "unexpected message " ++ show p in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + process p = + let reason = "unexpected message " ++ show p + in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - loopHandshake13 [] = return () - loopHandshake13 (ClientHello13{}:_) = do - let reason = "Client hello is not allowed" + 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 + role <- usingState_ ctx S.getRole + unless (role == ClientRole) $ + let reason = "Session ticket is allowed for client only" + in terminate (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 = case extensionLookup EID_EarlyData exts + >>= extensionDecode MsgTNewSessionTicket of + Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms + _ -> 0 + 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 + modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} + loopHandshake13 hs + loopHandshake13 (KeyUpdate13 mode : hs) = do + when (ctxQUICMode ctx) $ do + let reason = "KeyUpdate is not allowed for QUIC" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - -- 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 - role <- usingState_ ctx S.isClientContext - unless (role == ClientRole) $ - let reason = "Session ticket is allowed for client only" - in terminate (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 resumptionMasterSecret <- usingHState ctx getTLS13ResumptionSecret - (_, usedCipher, _, _) <- getTxState ctx - let choice = makeCipherChoice TLS13 usedCipher - psk = derivePSK choice resumptionMasterSecret nonce - maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of - Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms - _ -> 0 - 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 - sessionEstablish (sharedSessionManager $ ctxShared ctx) label' sdata - -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec" - loopHandshake13 hs - loopHandshake13 (KeyUpdate13 mode:hs) = do - when (ctxQUICMode ctx) $ do - let reason = "KeyUpdate is not allowed for QUIC" - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - checkAlignment hs - established <- ctxEstablished ctx - -- Though RFC 8446 Sec 4.6.3 does not clearly says, - -- unidirectional key update is legal. - -- So, we don't have to check if this key update is corresponding - -- to key update (update_requested) which we sent. - if established == Established then do - keyUpdate ctx getRxState setRxState + checkAlignment hs + established <- ctxEstablished ctx + -- Though RFC 8446 Sec 4.6.3 does not clearly says, + -- unidirectional key update is legal. + -- So, we don't have to check if this key update is corresponding + -- to key update (update_requested) which we sent. + if established == Established + then 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 getTxState setTxState + keyUpdate ctx getTxRecordState setTxRecordState loopHandshake13 hs - else do + else do let reason = "received key update before established" terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - loopHandshake13 (h@CertRequest13{}:hs) = - postHandshakeAuthWith ctx h >> loopHandshake13 hs - loopHandshake13 (h@Certificate13{}:hs) = - postHandshakeAuthWith ctx h >> loopHandshake13 hs - loopHandshake13 (h:hs) = do - mPendingAction <- popPendingAction ctx - case mPendingAction of - Nothing -> let reason = "unexpected handshake message " ++ show h in - terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - Just action -> do - -- Pending actions are executed with read+write locks, just - -- like regular handshake code. - withWriteLock ctx $ handleException ctx $ + 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 - PendingAction needAligned pa -> do + PendingRecvAction needAligned pa -> do when needAligned $ checkAlignment hs - processHandshake13 ctx h >> pa h - PendingActionHash needAligned pa -> do + processHandshake13 ctx h + pa h + PendingRecvActionHash needAligned pa -> do when needAligned $ checkAlignment hs d <- transcriptHash ctx processHandshake13 ctx h pa d h - loopHandshake13 hs + -- 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 - terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) + terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) - checkAlignment hs = do - complete <- isRecvComplete ctx - unless (complete && null hs) $ - let reason = "received message not aligned with record boundary" - in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason + checkAlignment hs = do + complete <- isRecvComplete ctx + unless (complete && null hs) $ + let reason = "received message not aligned with record boundary" + in terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions tryBye :: Context -> IO () -tryBye ctx = catchException (bye ctx) (\_ -> return ()) +tryBye ctx = catchException (bye_ ctx) (\_ -> return ()) -onError :: Monad m => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString) - -> TLSError -> m B.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 + :: Monad m + => (TLSError -> AlertLevel -> AlertDescription -> String -> m B.ByteString) + -> TLSError + -> m B.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) -terminateWithWriteLock :: Context -> ([(AlertLevel, AlertDescription)] -> IO ()) - -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a +terminateWithWriteLock + :: Context + -> ([(AlertLevel, AlertDescription)] -> IO ()) + -> TLSError + -> AlertLevel + -> 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 case session of - Session Nothing -> return () + Session Nothing -> return () Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid catchException (send [(level, desc)]) (\_ -> return ()) setEOF ctx E.throwIO (Terminated False reason err) - {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} + -- | same as recvData but returns a lazy bytestring. recvData' :: MonadIO m => Context -> m L.ByteString -recvData' ctx = L.fromChunks . (:[]) <$> recvData ctx +recvData' ctx = L.fromChunks . (: []) <$> recvData ctx -keyUpdate :: Context - -> (Context -> IO (Hash,Cipher,CryptLevel,C8.ByteString)) - -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()) - -> IO () +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 + 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 = OneWay -- ^ Unidirectional key update - | TwoWay -- ^ Bidirectional key update (normal case) - deriving (Eq, Show) +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. @@ -332,5 +450,5 @@ -- be sent by another thread before the Tx state is updated. withWriteLock ctx $ do sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] - keyUpdate ctx getTxState setTxState + keyUpdate ctx getTxRecordState setTxRecordState return tls13 diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -1,34 +1,28 @@ --- | --- Module : Network.TLS.Credentials --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- {-# LANGUAGE CPP #-} -module Network.TLS.Credentials - ( Credential - , Credentials(..) - , credentialLoadX509 - , credentialLoadX509FromMemory - , credentialLoadX509Chain - , credentialLoadX509ChainFromMemory - , credentialsFindForSigning - , credentialsFindForDecrypting - , credentialsListSigningAlgorithms - , credentialPublicPrivateKeys - , credentialMatchesHashSignatures - ) where -import Network.TLS.Crypto -import Network.TLS.X509 -import Network.TLS.Imports +module Network.TLS.Credentials ( + Credential, + Credentials (..), + credentialLoadX509, + credentialLoadX509FromMemory, + credentialLoadX509Chain, + credentialLoadX509ChainFromMemory, + credentialsFindForSigning, + credentialsFindForDecrypting, + credentialsListSigningAlgorithms, + credentialPublicPrivateKeys, + credentialMatchesHashSignatures, +) where + +import Data.X509 import Data.X509.File import Data.X509.Memory -import Data.X509 +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 qualified Data.X509 as X509 +import qualified Network.TLS.Struct as TLS type Credential = (CertificateChain, PrivKey) @@ -46,60 +40,71 @@ -- | try to create a new credential object from a public certificate -- and the associated private key that are stored on the filesystem -- in PEM format. -credentialLoadX509 :: FilePath -- ^ public certificate (X.509 format) - -> FilePath -- ^ private key associated - -> IO (Either String Credential) +credentialLoadX509 + :: FilePath + -- ^ public certificate (X.509 format) + -> FilePath + -- ^ private key associated + -> IO (Either String Credential) credentialLoadX509 certFile = credentialLoadX509Chain certFile [] -- | similar to 'credentialLoadX509' but take the certificate -- and private key from memory instead of from the filesystem. -credentialLoadX509FromMemory :: ByteString - -> ByteString - -> Either String Credential +credentialLoadX509FromMemory + :: ByteString + -> ByteString + -> Either String Credential credentialLoadX509FromMemory certData = - credentialLoadX509ChainFromMemory certData [] + credentialLoadX509ChainFromMemory certData [] -- | similar to 'credentialLoadX509' but also allow specifying chain -- certificates. -credentialLoadX509Chain :: - FilePath -- ^ public certificate (X.509 format) - -> [FilePath] -- ^ chain certificates (X.509 format) - -> FilePath -- ^ private key associated - -> IO (Either String Credential) +credentialLoadX509Chain + :: FilePath + -- ^ public certificate (X.509 format) + -> [FilePath] + -- ^ chain certificates (X.509 format) + -> FilePath + -- ^ private key associated + -> IO (Either String Credential) credentialLoadX509Chain certFile chainFiles privateFile = do x509 <- readSignedObject certFile chains <- mapM readSignedObject chainFiles keys <- readKeyFile privateFile case keys of - [] -> return $ Left "no keys found" - (k:_) -> return $ Right (CertificateChain . concat $ x509 : chains, k) + [] -> return $ Left "no keys found" + (k : _) -> return $ Right (CertificateChain . concat $ x509 : chains, k) -- | similar to 'credentialLoadX509FromMemory' but also allow -- specifying chain certificates. -credentialLoadX509ChainFromMemory :: ByteString - -> [ByteString] - -> ByteString - -> Either String Credential +credentialLoadX509ChainFromMemory + :: ByteString + -> [ByteString] + -> ByteString + -> Either String Credential credentialLoadX509ChainFromMemory certData chainData privateData = - let x509 = readSignedObjectFromMemory certData + let x509 = readSignedObjectFromMemory certData chains = map readSignedObjectFromMemory chainData - keys = readKeyFileFromMemory privateData + keys = readKeyFileFromMemory privateData in case keys of - [] -> Left "no keys found" - (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) + [] -> Left "no keys found" + (k : _) -> Right (CertificateChain . concat $ x509 : chains, k) credentialsListSigningAlgorithms :: Credentials -> [KeyExchangeSignatureAlg] credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l -credentialsFindForSigning :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential +credentialsFindForSigning + :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning kxsAlg (Credentials l) = find forSigning l - where forSigning cred = case credentialCanSign cred of - Nothing -> False - Just kxs -> kxs == kxsAlg + where + forSigning cred = case credentialCanSign cred of + Nothing -> False + Just kxs -> kxs == kxsAlg credentialsFindForDecrypting :: Credentials -> Maybe Credential credentialsFindForDecrypting (Credentials l) = find forEncrypting l - where forEncrypting cred = Just () == credentialCanDecrypt cred + where + forEncrypting cred = Just () == credentialCanDecrypt cred -- here we assume that only RSA is supported for key encipherment (encryption/decryption) -- we keep the same construction as 'credentialCanSign', returning a Maybe of () in case @@ -109,69 +114,71 @@ case (pub, priv) of (PubKeyRSA _, PrivKeyRSA _) -> case extensionGet (certExtensions cert) of - Nothing -> Just () + Nothing -> Just () Just (ExtKeyUsage flags) | KeyUsage_keyEncipherment `elem` flags -> Just () - | otherwise -> Nothing - _ -> Nothing - where cert = getCertificate signed - pub = certPubKey cert - signed = getCertificateChainLeaf chain + | otherwise -> Nothing + _ -> Nothing + where + cert = getCertificate signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain credentialCanSign :: Credential -> Maybe KeyExchangeSignatureAlg credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of - Nothing -> findKeyExchangeSignatureAlg (pub, priv) + Nothing -> findKeyExchangeSignatureAlg (pub, priv) Just (ExtKeyUsage flags) - | KeyUsage_digitalSignature `elem` flags -> findKeyExchangeSignatureAlg (pub, priv) - | otherwise -> Nothing - where cert = getCertificate signed - pub = certPubKey cert - signed = getCertificateChainLeaf chain + | KeyUsage_digitalSignature `elem` flags -> + findKeyExchangeSignatureAlg (pub, priv) + | otherwise -> Nothing + where + cert = getCertificate signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain credentialPublicPrivateKeys :: Credential -> (PubKey, PrivKey) credentialPublicPrivateKeys (chain, priv) = pub `seq` (pub, priv) - where cert = getCertificate signed - pub = certPubKey cert - signed = getCertificateChainLeaf chain + where + cert = getCertificate signed + pub = certPubKey cert + signed = getCertificateChainLeaf chain getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm getHashSignature signed = case signedAlg $ getSigned signed of - SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg - SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSS hashAlg - SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg - + SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg + SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSA hashAlg + SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA256) SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA384) SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA512) - - SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519) - SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448) - - _ -> Nothing + SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519) + SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448) + _ -> Nothing where - convertHash sig X509.HashMD5 = Just (TLS.HashMD5 , sig) - convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1 , sig) + convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig) + convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1, sig) convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) - convertHash _ _ = Nothing + convertHash _ _ = Nothing -- | Checks whether certificate signatures in the chain comply with a list of -- hash/signature algorithm pairs. Currently the verification applies only to -- the signature of the leaf certificate, and when not self-signed. This may -- be extended to additional chain elements in the future. -credentialMatchesHashSignatures :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool +credentialMatchesHashSignatures + :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool credentialMatchesHashSignatures hashSigs (chain, _) = case chain of - CertificateChain [] -> True - CertificateChain (leaf:_) -> isSelfSigned leaf || matchHashSig leaf + CertificateChain [] -> True + CertificateChain (leaf : _) -> isSelfSigned leaf || matchHashSig leaf where matchHashSig signed = case getHashSignature signed of - Nothing -> False - Just hs -> hs `elem` hashSigs + Nothing -> False + Just hs -> hs `elem` hashSigs isSelfSigned signed = let cert = getCertificate signed diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -1,53 +1,50 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} -module Network.TLS.Crypto - ( HashContext - , HashCtx - , hashInit - , hashUpdate - , hashUpdateSSL - , hashFinal +{-# OPTIONS_HADDOCK hide #-} - , module Network.TLS.Crypto.DH - , module Network.TLS.Crypto.IES - , module Network.TLS.Crypto.Types +module Network.TLS.Crypto ( + HashContext, + HashCtx, + hashInit, + hashUpdate, + hashUpdateSSL, + hashFinal, + module Network.TLS.Crypto.DH, + module Network.TLS.Crypto.IES, + module Network.TLS.Crypto.Types, -- * Hash - , hash - , Hash(..) - , hashName - , hashDigestSize - , hashBlockSize + hash, + Hash (..), + hashName, + hashDigestSize, + hashBlockSize, -- * key exchange generic interface - , PubKey(..) - , PrivKey(..) - , PublicKey - , PrivateKey - , SignatureParams(..) - , isKeyExchangeSignatureKey - , findKeyExchangeSignatureAlg - , findFiniteFieldGroup - , findEllipticCurveGroup - , kxEncrypt - , kxDecrypt - , kxSign - , kxVerify - , kxCanUseRSApkcs1 - , kxCanUseRSApss - , kxSupportedPrivKeyEC - , KxError(..) - , RSAEncoding(..) - ) where + PubKey (..), + PrivKey (..), + PublicKey, + PrivateKey, + SignatureParams (..), + isKeyExchangeSignatureKey, + findKeyExchangeSignatureAlg, + findFiniteFieldGroup, + findEllipticCurveGroup, + kxEncrypt, + kxDecrypt, + kxSign, + kxVerify, + kxCanUseRSApkcs1, + kxCanUseRSApss, + kxSupportedPrivKeyEC, + KxError (..), + RSAEncoding (..), +) where -import qualified Crypto.Hash as H -import qualified Data.ByteString as B -import qualified Data.ByteArray as B (convert) +import qualified Crypto.ECC as ECDSA import Crypto.Error +import qualified Crypto.Hash as H import Crypto.Number.Basic (numBits) -import Crypto.Random -import qualified Crypto.ECC as ECDSA import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA_ECC @@ -58,18 +55,26 @@ import qualified Crypto.PubKey.RSA as RSA 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 qualified Data.ByteString as B -import Data.X509 (PrivKey(..), PubKey(..), PrivKeyEC(..), PubKeyEC(..), - SerializedPoint(..)) +import Data.X509 ( + PrivKey (..), + PrivKeyEC (..), + PubKey (..), + PubKeyEC (..), + 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.Types +import Data.ASN1.BinaryEncoding (BER (..), DER (..)) import Data.ASN1.Encoding -import Data.ASN1.BinaryEncoding (DER(..), BER(..)) +import Data.ASN1.Types import Data.Proxy @@ -78,39 +83,40 @@ {-# DEPRECATED PrivateKey "use PrivKey" #-} type PrivateKey = PrivKey -data KxError = - RSAError RSA.Error +data KxError + = RSAError RSA.Error | KxUnsupported deriving (Show) isKeyExchangeSignatureKey :: KeyExchangeSignatureAlg -> PubKey -> Bool isKeyExchangeSignatureKey = f where - f KX_RSA (PubKeyRSA _) = True - f KX_DSS (PubKeyDSA _) = True - f KX_ECDSA (PubKeyEC _) = True - f KX_ECDSA (PubKeyEd25519 _) = True - f KX_ECDSA (PubKeyEd448 _) = True - f _ _ = False + f KX_RSA (PubKeyRSA _) = True + f KX_DSA (PubKeyDSA _) = True + f KX_ECDSA (PubKeyEC _) = True + f KX_ECDSA (PubKeyEd25519 _) = True + f KX_ECDSA (PubKeyEd448 _) = True + f _ _ = False -findKeyExchangeSignatureAlg :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg +findKeyExchangeSignatureAlg + :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg findKeyExchangeSignatureAlg keyPair = case keyPair of - (PubKeyRSA _, PrivKeyRSA _) -> Just KX_RSA - (PubKeyDSA _, PrivKeyDSA _) -> Just KX_DSS - (PubKeyEC _, PrivKeyEC _) -> Just KX_ECDSA - (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just KX_ECDSA - (PubKeyEd448 _, PrivKeyEd448 _) -> Just KX_ECDSA - _ -> Nothing + (PubKeyRSA _, PrivKeyRSA _) -> Just KX_RSA + (PubKeyDSA _, PrivKeyDSA _) -> Just KX_DSA + (PubKeyEC _, PrivKeyEC _) -> Just KX_ECDSA + (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just KX_ECDSA + (PubKeyEd448 _, PrivKeyEd448 _) -> Just KX_ECDSA + _ -> Nothing findFiniteFieldGroup :: DH.Params -> Maybe Group findFiniteFieldGroup params = lookup (pg params) table where pg (DH.Params p g _) = (p, g) - table = [ (pg prms, grp) | grp <- availableFFGroups - , let Just prms = dhParamsForGroup grp - ] + table = + [ (pg prms, grp) | grp <- availableFFGroups, let prms = fromJust $ dhParamsForGroup grp + ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group findEllipticCurveGroup ecPub = @@ -118,16 +124,16 @@ Just ECC.SEC_p256r1 -> Just P256 Just ECC.SEC_p384r1 -> Just P384 Just ECC.SEC_p521r1 -> Just P521 - _ -> Nothing + _ -> Nothing -- functions to use the hidden class. hashInit :: Hash -> HashContext -hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5) -hashInit SHA1 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA1) -hashInit SHA224 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA224) -hashInit SHA256 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA256) -hashInit SHA384 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA384) -hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) +hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5) +hashInit SHA1 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA1) +hashInit SHA224 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA224) +hashInit SHA256 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA256) +hashInit SHA384 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA384) +hashInit SHA512 = HashContext $ ContextSimple (H.hashInit :: H.Context H.SHA512) hashInit SHA1_MD5 = HashContextSSL H.hashInit H.hashInit hashUpdate :: HashContext -> B.ByteString -> HashCtx @@ -135,11 +141,13 @@ hashUpdate (HashContextSSL sha1Ctx md5Ctx) b = HashContextSSL (H.hashUpdate sha1Ctx b) (H.hashUpdate md5Ctx b) -hashUpdateSSL :: HashCtx - -> (B.ByteString,B.ByteString) -- ^ (for the md5 context, for the sha1 context) - -> HashCtx +hashUpdateSSL + :: HashCtx + -> (B.ByteString, B.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) = +hashUpdateSSL (HashContextSSL sha1Ctx md5Ctx) (b1, b2) = HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) hashFinal :: HashCtx -> B.ByteString @@ -148,26 +156,27 @@ B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 - deriving (Show,Eq) + deriving (Show, Eq) -data HashContext = - HashContext ContextSimple +data HashContext + = HashContext ContextSimple | HashContextSSL (H.Context H.SHA1) (H.Context H.MD5) instance Show HashContext where show _ = "hash-context" -data ContextSimple = forall alg . H.HashAlgorithm alg => ContextSimple (H.Context alg) +data ContextSimple + = forall alg. H.HashAlgorithm alg => ContextSimple (H.Context alg) 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 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 @@ -181,8 +190,8 @@ -- | Digest size in bytes. hashDigestSize :: Hash -> Int -hashDigestSize MD5 = 16 -hashDigestSize SHA1 = 20 +hashDigestSize MD5 = 16 +hashDigestSize SHA1 = 20 hashDigestSize SHA224 = 28 hashDigestSize SHA256 = 32 hashDigestSize SHA384 = 48 @@ -190,8 +199,8 @@ hashDigestSize SHA1_MD5 = 36 hashBlockSize :: Hash -> Int -hashBlockSize MD5 = 64 -hashBlockSize SHA1 = 64 +hashBlockSize MD5 = 64 +hashBlockSize SHA1 = 64 hashBlockSize SHA224 = 64 hashBlockSize SHA256 = 64 hashBlockSize SHA384 = 128 @@ -201,18 +210,20 @@ {- key exchange methods encrypt and decrypt for each supported algorithm -} generalizeRSAError :: Either RSA.Error a -> Either KxError a -generalizeRSAError (Left e) = Left (RSAError e) +generalizeRSAError (Left e) = Left (RSAError e) generalizeRSAError (Right x) = Right x -kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) +kxEncrypt + :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b -kxEncrypt _ _ = return (Left KxUnsupported) +kxEncrypt _ _ = return (Left KxUnsupported) -kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) +kxDecrypt + :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b -kxDecrypt _ _ = return (Left KxUnsupported) +kxDecrypt _ _ = return (Left KxUnsupported) -data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq) +data RSAEncoding = RSApkcs1 | RSApss deriving (Show, Eq) -- | Test the RSASSA-PKCS1 length condition described in RFC 8017 section 9.2, -- i.e. @emLen >= tLen + 11@. Lengths are in bytes. @@ -221,13 +232,13 @@ where tLen = prefixSize h + hashDigestSize h - prefixSize MD5 = 18 - prefixSize SHA1 = 15 + prefixSize MD5 = 18 + prefixSize SHA1 = 15 prefixSize SHA224 = 19 prefixSize SHA256 = 19 prefixSize SHA384 = 19 prefixSize SHA512 = 19 - prefixSize _ = error (show h ++ " is not supported for RSASSA-PKCS1") + prefixSize _ = error (show h ++ " is not supported for RSASSA-PKCS1") -- | Test the RSASSA-PSS length condition described in RFC 8017 section 9.1.1, -- i.e. @emBits >= 8hLen + 8sLen + 9@. Lengths are in bits. @@ -237,45 +248,45 @@ -- Signature algorithm and associated parameters. -- -- FIXME add RSAPSSParams -data SignatureParams = - RSAParams Hash RSAEncoding - | DSSParams - | ECDSAParams Hash +data SignatureParams + = RSAParams Hash RSAEncoding + | DSAParams + | ECDSAParams Hash | Ed25519Params | Ed448Params - deriving (Show,Eq) + deriving (Show, Eq) -- Verify that the signature matches the given message, using the -- public key. -- kxVerify :: PublicKey -> SignatureParams -> ByteString -> ByteString -> Bool -kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign -kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign -kxVerify (PubKeyDSA pk) DSSParams msg signBS = - +kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign +kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign +kxVerify (PubKeyDSA pk) DSAParams msg signBS = case dsaToSignature signBS of Just sig -> DSA.verify H.SHA1 pk sig msg - _ -> False + _ -> False where - dsaToSignature :: ByteString -> Maybe DSA.Signature - dsaToSignature b = - case decodeASN1' BER b of - Left _ -> Nothing - Right asn1 -> - case asn1 of - Start Sequence:IntVal r:IntVal s:End Sequence:_ -> - Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } - _ -> - Nothing + dsaToSignature :: ByteString -> Maybe DSA.Signature + dsaToSignature b = + case decodeASN1' BER b of + Left _ -> Nothing + Right asn1 -> + case asn1 of + Start Sequence : IntVal r : IntVal s : End Sequence : _ -> + Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} + _ -> + Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = - fromMaybe False $ join $ - withPubKeyEC key verifyProxy verifyClassic Nothing + fromMaybe False $ + join $ + withPubKeyEC key verifyProxy verifyClassic Nothing where decodeSignatureASN1 buildRS = case decodeASN1' BER sigBS of - Left _ -> Nothing - Right [Start Sequence,IntVal r,IntVal s,End Sequence] -> + Left _ -> Nothing + Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> Just (buildRS r s) Right _ -> Nothing verifyProxy prx pubkey = do @@ -287,53 +298,63 @@ signature <- decodeSignatureASN1 ECDSA_ECC.Signature verifyF <- withAlg ECDSA_ECC.verify return $ verifyF pubkey signature msg - withAlg :: (forall hash . H.HashAlgorithm hash => hash -> a) -> Maybe a + withAlg :: (forall hash. H.HashAlgorithm hash => hash -> a) -> Maybe a withAlg f = case alg of - MD5 -> Just (f H.MD5) - SHA1 -> Just (f H.SHA1) - SHA224 -> Just (f H.SHA224) - SHA256 -> Just (f H.SHA256) - SHA384 -> Just (f H.SHA384) - SHA512 -> Just (f H.SHA512) - _ -> Nothing + MD5 -> Just (f H.MD5) + SHA1 -> Just (f H.SHA1) + SHA224 -> Just (f H.SHA224) + SHA256 -> Just (f H.SHA256) + SHA384 -> Just (f H.SHA384) + SHA512 -> Just (f H.SHA512) + _ -> Nothing kxVerify (PubKeyEd25519 key) Ed25519Params msg sigBS = case Ed25519.signature sigBS of CryptoPassed sig -> Ed25519.verify key msg sig - _ -> False + _ -> False kxVerify (PubKeyEd448 key) Ed448Params msg sigBS = case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig - _ -> False -kxVerify _ _ _ _ = False + _ -> False +kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- -kxSign :: MonadRandom r - => PrivateKey - -> PublicKey - -> SignatureParams - -> ByteString - -> r (Either KxError ByteString) +kxSign + :: MonadRandom r + => PrivateKey + -> PublicKey + -> SignatureParams + -> ByteString + -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApkcs1) msg = generalizeRSAError <$> rsaSignHash hashAlg pk msg kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApss) msg = generalizeRSAError <$> rsapssSignHash hashAlg pk msg -kxSign (PrivKeyDSA pk) (PubKeyDSA _) DSSParams msg = do +kxSign (PrivKeyDSA pk) (PubKeyDSA _) DSAParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign) - where dsaSequence sign = [Start Sequence,IntVal (DSA.sign_r sign),IntVal (DSA.sign_s sign),End Sequence] + where + dsaSequence sign = + [ Start Sequence + , IntVal (DSA.sign_r sign) + , IntVal (DSA.sign_s sign) + , End Sequence + ] kxSign (PrivKeyEC pk) (PubKeyEC _) (ECDSAParams hashAlg) msg = case withPrivKeyEC pk doSign (const unsupported) unsupported of - Nothing -> unsupported + Nothing -> unsupported Just run -> fmap encode <$> run - where encode (r, s) = encodeASN1' DER - [ Start Sequence, IntVal r, IntVal s, End Sequence ] - doSign prx privkey = do - msig <- ecdsaSignHash prx hashAlg privkey msg - return $ case msig of - Nothing -> Left KxUnsupported - Just sign -> Right (ECDSA.signatureToIntegers prx sign) - unsupported = return $ Left KxUnsupported + where + encode (r, s) = + encodeASN1' + DER + [Start Sequence, IntVal r, IntVal s, End Sequence] + doSign prx privkey = do + msig <- ecdsaSignHash prx hashAlg privkey msg + return $ case msig of + Nothing -> Left KxUnsupported + 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 kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = @@ -341,91 +362,120 @@ kxSign _ _ _ _ = return (Left KxUnsupported) -rsaSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) +rsaSignHash + :: MonadRandom m + => Hash + -> RSA.PrivateKey + -> ByteString + -> m (Either RSA.Error ByteString) rsaSignHash SHA1_MD5 pk msg = RSA.signSafer noHash pk msg -rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg -rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg -rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg -rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg -rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg -rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg +rsaSignHash MD5 pk msg = RSA.signSafer (Just H.MD5) pk msg +rsaSignHash SHA1 pk msg = RSA.signSafer (Just H.SHA1) pk msg +rsaSignHash SHA224 pk msg = RSA.signSafer (Just H.SHA224) pk msg +rsaSignHash SHA256 pk msg = RSA.signSafer (Just H.SHA256) pk msg +rsaSignHash SHA384 pk msg = RSA.signSafer (Just H.SHA384) pk msg +rsaSignHash SHA512 pk msg = RSA.signSafer (Just H.SHA512) pk msg -rsapssSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) +rsapssSignHash + :: MonadRandom m + => Hash + -> RSA.PrivateKey + -> ByteString + -> m (Either RSA.Error ByteString) rsapssSignHash SHA256 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA256) pk msg rsapssSignHash SHA384 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA384) pk msg rsapssSignHash SHA512 pk msg = PSS.signSafer (PSS.defaultPSSParams H.SHA512) pk msg -rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" +rsapssSignHash _ _ _ = error "rsapssSignHash: unsupported hash" rsaVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsaVerifyHash SHA1_MD5 = RSA.verify noHash -rsaVerifyHash MD5 = RSA.verify (Just H.MD5) -rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1) -rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224) -rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256) -rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384) -rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) +rsaVerifyHash MD5 = RSA.verify (Just H.MD5) +rsaVerifyHash SHA1 = RSA.verify (Just H.SHA1) +rsaVerifyHash SHA224 = RSA.verify (Just H.SHA224) +rsaVerifyHash SHA256 = RSA.verify (Just H.SHA256) +rsaVerifyHash SHA384 = RSA.verify (Just H.SHA384) +rsaVerifyHash SHA512 = RSA.verify (Just H.SHA512) rsapssVerifyHash :: Hash -> RSA.PublicKey -> ByteString -> ByteString -> Bool rsapssVerifyHash SHA256 = PSS.verify (PSS.defaultPSSParams H.SHA256) rsapssVerifyHash SHA384 = PSS.verify (PSS.defaultPSSParams H.SHA384) rsapssVerifyHash SHA512 = PSS.verify (PSS.defaultPSSParams H.SHA512) -rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" +rsapssVerifyHash _ = error "rsapssVerifyHash: unsupported hash" noHash :: Maybe H.MD5 noHash = Nothing -ecdsaSignHash :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve) - => proxy curve -> Hash -> ECDSA.Scalar curve -> ByteString -> m (Maybe (ECDSA.Signature curve)) -ecdsaSignHash prx SHA1 pk msg = Just <$> ECDSA.sign prx pk H.SHA1 msg -ecdsaSignHash prx SHA224 pk msg = Just <$> ECDSA.sign prx pk H.SHA224 msg -ecdsaSignHash prx SHA256 pk msg = Just <$> ECDSA.sign prx pk H.SHA256 msg -ecdsaSignHash prx SHA384 pk msg = Just <$> ECDSA.sign prx pk H.SHA384 msg -ecdsaSignHash prx SHA512 pk msg = Just <$> ECDSA.sign prx pk H.SHA512 msg -ecdsaSignHash _ _ _ _ = return Nothing +ecdsaSignHash + :: (MonadRandom m, ECDSA.EllipticCurveECDSA curve) + => proxy curve + -> Hash + -> ECDSA.Scalar curve + -> ByteString + -> m (Maybe (ECDSA.Signature curve)) +ecdsaSignHash prx SHA1 pk msg = Just <$> ECDSA.sign prx pk H.SHA1 msg +ecdsaSignHash prx SHA224 pk msg = Just <$> ECDSA.sign prx pk H.SHA224 msg +ecdsaSignHash prx SHA256 pk msg = Just <$> ECDSA.sign prx pk H.SHA256 msg +ecdsaSignHash prx SHA384 pk msg = Just <$> ECDSA.sign prx pk H.SHA384 msg +ecdsaSignHash prx SHA512 pk msg = Just <$> ECDSA.sign prx pk H.SHA512 msg +ecdsaSignHash _ _ _ _ = return Nothing -- Currently we generate ECDSA signatures in constant time for P256 only. kxSupportedPrivKeyEC :: PrivKeyEC -> Bool kxSupportedPrivKeyEC privkey = case ecPrivKeyCurveName privkey of Just ECC.SEC_p256r1 -> True - _ -> False + _ -> False -- Perform a public-key operation with a parameterized ECC implementation when -- available, otherwise fallback to the classic ECC implementation. -withPubKeyEC :: PubKeyEC - -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PublicKey curve -> a) - -> (ECDSA_ECC.PublicKey -> a) - -> a - -> Maybe a +withPubKeyEC + :: PubKeyEC + -> ( forall curve + . ECDSA.EllipticCurveECDSA curve + => Proxy curve + -> ECDSA.PublicKey curve + -> a + ) + -> (ECDSA_ECC.PublicKey -> a) + -> a + -> Maybe a withPubKeyEC pubkey withProxy withClassic whenUnknown = case ecPubKeyCurveName pubkey of - Nothing -> Just whenUnknown + Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> maybeCryptoError $ withProxy p256 <$> ECDSA.decodePublic p256 bs - Just curveName -> + Just curveName -> let curve = ECC.getCurveByName curveName - pub = unserializePoint curve pt + pub = unserializePoint curve pt in withClassic . ECDSA_ECC.PublicKey curve <$> pub - where pt@(SerializedPoint bs) = pubkeyEC_pub pubkey + where + pt@(SerializedPoint bs) = pubkeyEC_pub pubkey -- Perform a private-key operation with a parameterized ECC implementation when -- available. Calls for an unsupported curve can be prevented with -- kxSupportedEcPrivKey. -withPrivKeyEC :: PrivKeyEC - -> (forall curve . ECDSA.EllipticCurveECDSA curve => Proxy curve -> ECDSA.PrivateKey curve -> a) - -> (ECC.CurveName -> a) - -> a - -> Maybe a +withPrivKeyEC + :: PrivKeyEC + -> ( forall curve + . ECDSA.EllipticCurveECDSA curve + => Proxy curve + -> ECDSA.PrivateKey curve + -> a + ) + -> (ECC.CurveName -> a) + -> a + -> Maybe a withPrivKeyEC privkey withProxy withUnsupported whenUnknown = case ecPrivKeyCurveName privkey of - Nothing -> Just whenUnknown + Nothing -> Just whenUnknown Just ECC.SEC_p256r1 -> -- Private key should rather be stored as bytearray and converted -- using ECDSA.decodePrivate, unfortunately the data type chosen in -- x509 was Integer. maybeCryptoError $ withProxy p256 <$> ECDSA.scalarFromInteger p256 d - Just curveName -> Just $ withUnsupported curveName - where d = privkeyEC_priv privkey + Just curveName -> Just $ withUnsupported curveName + where + d = privkeyEC_priv privkey p256 :: Proxy ECDSA.Curve_P256R1 p256 = Proxy diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -1,34 +1,33 @@ -module Network.TLS.Crypto.DH - ( +module Network.TLS.Crypto.DH ( -- * DH types - DHParams - , DHPublic - , DHPrivate - , DHKey + DHParams, + DHPublic, + DHPrivate, + DHKey, -- * DH methods - , dhPublic - , dhPrivate - , dhParams - , dhParamsGetP - , dhParamsGetG - , dhParamsGetBits - , dhGenerateKeyPair - , dhGetShared - , dhValid - , dhUnwrap - , dhUnwrapPublic - ) where + dhPublic, + dhPrivate, + dhParams, + dhParamsGetP, + dhParamsGetG, + dhParamsGetBits, + dhGenerateKeyPair, + dhGetShared, + dhValid, + dhUnwrap, + dhUnwrapPublic, +) where +import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH -import Crypto.Number.Basic (numBits) import qualified Data.ByteArray as B -import Network.TLS.RNG +import Network.TLS.RNG -type DHPublic = DH.PublicNumber -type DHPrivate = DH.PrivateNumber -type DHParams = DH.Params -type DHKey = DH.SharedKey +type DHPublic = DH.PublicNumber +type DHPrivate = DH.PrivateNumber +type DHParams = DH.Params +type DHKey = DH.SharedKey dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber @@ -42,7 +41,7 @@ dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params - let pub = DH.calculatePublic params priv + let pub = DH.calculatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey @@ -50,7 +49,7 @@ stripLeadingZeros (DH.getShared params priv pub) where -- strips leading zeros from the result of DH.getShared, as required - -- for DH(E) premaster secret in SSL/TLS before version 1.3. + -- for DH(E) pre-main secret in SSL/TLS before version 1.3. stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb) -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. @@ -60,7 +59,7 @@ dhValid (DH.Params p _ _) y = 1 < y && y < p - 1 dhUnwrap :: DHParams -> DHPublic -> [Integer] -dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y] +dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p, g, y] dhParamsGetP :: DHParams -> Integer dhParamsGetP (DH.Params p _ _) = p diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -4,23 +4,23 @@ -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Crypto.IES - ( - GroupPublic - , GroupPrivate - , GroupKey +module Network.TLS.Crypto.IES ( + GroupPublic, + GroupPrivate, + GroupKey, + -- * Group methods - , groupGenerateKeyPair - , groupGetPubShared - , groupGetShared - , encodeGroupPublic - , decodeGroupPublic + groupGenerateKeyPair, + groupGetPubShared, + groupGetShared, + encodeGroupPublic, + decodeGroupPublic, + -- * Compatibility with 'Network.TLS.Crypto.DH' - , dhParamsForGroup - , dhGroupGenerateKeyPair - , dhGroupGetPubShared - ) where + dhParamsForGroup, + dhGroupGenerateKeyPair, + dhGroupGetPubShared, +) where import Control.Arrow import Crypto.ECC @@ -34,31 +34,33 @@ import Network.TLS.Extra.FFDHE import Network.TLS.Imports import Network.TLS.RNG -import Network.TLS.Util.Serialization (os2ip,i2ospOf_) +import Network.TLS.Util.Serialization (i2ospOf_, os2ip) -data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) - | GroupPri_P384 (Scalar Curve_P384R1) - | GroupPri_P521 (Scalar Curve_P521R1) - | GroupPri_X255 (Scalar Curve_X25519) - | GroupPri_X448 (Scalar Curve_X448) - | GroupPri_FFDHE2048 PrivateNumber - | GroupPri_FFDHE3072 PrivateNumber - | GroupPri_FFDHE4096 PrivateNumber - | GroupPri_FFDHE6144 PrivateNumber - | GroupPri_FFDHE8192 PrivateNumber - deriving (Eq, Show) +data GroupPrivate + = GroupPri_P256 (Scalar Curve_P256R1) + | GroupPri_P384 (Scalar Curve_P384R1) + | GroupPri_P521 (Scalar Curve_P521R1) + | GroupPri_X255 (Scalar Curve_X25519) + | GroupPri_X448 (Scalar Curve_X448) + | GroupPri_FFDHE2048 PrivateNumber + | GroupPri_FFDHE3072 PrivateNumber + | GroupPri_FFDHE4096 PrivateNumber + | GroupPri_FFDHE6144 PrivateNumber + | GroupPri_FFDHE8192 PrivateNumber + deriving (Eq, Show) -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 - deriving (Eq, Show) +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 + deriving (Eq, Show) type GroupKey = SharedSecret @@ -83,47 +85,51 @@ dhParamsForGroup FFDHE4096 = Just ffdhe4096 dhParamsForGroup FFDHE6144 = Just ffdhe6144 dhParamsForGroup FFDHE8192 = Just ffdhe8192 -dhParamsForGroup _ = Nothing +dhParamsForGroup _ = Nothing groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) -groupGenerateKeyPair P256 = - (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256 -groupGenerateKeyPair P384 = - (GroupPri_P384,GroupPub_P384) `fs` curveGenerateKeyPair p384 -groupGenerateKeyPair P521 = - (GroupPri_P521,GroupPub_P521) `fs` curveGenerateKeyPair p521 +groupGenerateKeyPair P256 = + (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256 +groupGenerateKeyPair P384 = + (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384 +groupGenerateKeyPair P521 = + (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 = - (GroupPri_X255,GroupPub_X255) `fs` curveGenerateKeyPair x25519 + (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 = - (GroupPri_X448,GroupPub_X448) `fs` curveGenerateKeyPair 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 +groupGenerateKeyPair _ = error "groupGenerateKeyPair" -dhGroupGenerateKeyPair :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber) +dhGroupGenerateKeyPair + :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096) dhGroupGenerateKeyPair FFDHE6144 = addParams ffdhe6144 (gen' ffdhe6144 exp6144) dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) -dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) +dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) -fs :: MonadRandom r - => (Scalar a -> GroupPrivate, Point a -> GroupPublic) - -> r (KeyPair a) - -> r (GroupPrivate, GroupPublic) +fs + :: MonadRandom r + => (Scalar a -> GroupPrivate, Point a -> GroupPublic) + -> r (KeyPair a) + -> r (GroupPrivate, GroupPublic) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) -gen :: MonadRandom r +gen + :: MonadRandom r => Params -> Int -> (PrivateNumber -> GroupPrivate) @@ -131,13 +137,15 @@ -> r (GroupPrivate, GroupPublic) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits -gen' :: MonadRandom r - => Params - -> Int - -> r (PrivateNumber, PublicNumber) +gen' + :: MonadRandom r + => Params + -> Int + -> r (PrivateNumber, PublicNumber) gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits -groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) +groupGetPubShared + :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) groupGetPubShared (GroupPub_P256 pub) = fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub groupGetPubShared (GroupPub_P384 pub) = @@ -154,32 +162,36 @@ groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144 groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192 -dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey)) +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 -dhGroupGetPubShared _ _ = return Nothing +dhGroupGetPubShared _ _ = return Nothing -getPubShared :: MonadRandom r - => Params - -> Int - -> PublicNumber - -> (PublicNumber -> GroupPublic) - -> r (Maybe (GroupPublic, GroupKey)) -getPubShared 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) +getPubShared + :: MonadRandom r + => Params + -> Int + -> PublicNumber + -> (PublicNumber -> GroupPublic) + -> r (Maybe (GroupPublic, GroupKey)) +getPubShared 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) -getPubShared' :: MonadRandom r - => Params - -> Int - -> PublicNumber - -> r (Maybe (PublicNumber, SharedKey)) +getPubShared' + :: MonadRandom r + => Params + -> Int + -> PublicNumber + -> r (Maybe (PublicNumber, SharedKey)) getPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do @@ -187,7 +199,7 @@ let share = stripLeadingZeros (getShared params mypri pub) return $ Just (calculatePublic params mypri, SharedKey share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey +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 @@ -203,7 +215,7 @@ calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret calcShared params pub pri | valid params pub = Just $ SharedSecret share - | otherwise = Nothing + | otherwise = Nothing where SharedKey share = getShared params pri pub @@ -223,9 +235,9 @@ enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p 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 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 @@ -233,6 +245,7 @@ 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" -- 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. @@ -240,7 +253,7 @@ valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required --- for DH(E) premaster secret in SSL/TLS before version 1.3. +-- 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 diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -1,23 +1,85 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} + -- | -- Module : Network.TLS.Crypto.Types -- License : BSD-style -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Crypto.Types where +module Network.TLS.Crypto.Types ( + Group ( + Group, + P256, + P384, + P521, + X25519, + X448, + FFDHE2048, + FFDHE3072, + FFDHE4096, + FFDHE6144, + FFDHE8192 + ), + availableFFGroups, + availableECGroups, + supportedNamedGroups, + KeyExchangeSignatureAlg (..), +) where -data Group = P256 | P384 | P521 | X25519 | X448 - | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 - deriving (Eq, Show) +import Codec.Serialise +import Data.Word +import GHC.Generics +newtype Group = Group Word16 deriving (Eq, Generic) +instance Serialise Group + +{- FOURMOLU_DISABLE -} +pattern P256 :: Group +pattern P256 = Group 23 +pattern P384 :: Group +pattern P384 = Group 24 +pattern P521 :: Group +pattern P521 = Group 25 +pattern X25519 :: Group +pattern X25519 = Group 29 +pattern X448 :: Group +pattern X448 = Group 30 +pattern FFDHE2048 :: Group +pattern FFDHE2048 = Group 256 +pattern FFDHE3072 :: Group +pattern FFDHE3072 = Group 257 +pattern FFDHE4096 :: Group +pattern FFDHE4096 = Group 258 +pattern FFDHE6144 :: Group +pattern FFDHE6144 = Group 259 +pattern FFDHE8192 :: Group +pattern FFDHE8192 = Group 260 + +instance Show Group where + show P256 = "P256" + show P384 = "P384" + show P521 = "P521" + show X25519 = "X25519" + show X448 = "X448" + show FFDHE2048 = "FFDHE2048" + show FFDHE3072 = "FFDHE3072" + show FFDHE4096 = "FFDHE4096" + show FFDHE6144 = "FFDHE6144" + show FFDHE8192 = "FFDHE8192" + show (Group x) = "Group " ++ show x +{- FOURMOLU_ENABLE -} + availableFFGroups :: [Group] -availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192] +availableFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192] availableECGroups :: [Group] -availableECGroups = [P256,P384,P521,X25519,X448] +availableECGroups = [P256, P384, P521, X25519, X448] +supportedNamedGroups :: [Group] +supportedNamedGroups = [X25519, X448, P256, FFDHE3072, FFDHE4096, P384, FFDHE6144, FFDHE8192, P521] + -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). -data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA - deriving (Show, Eq) +data KeyExchangeSignatureAlg = KX_RSA | KX_DSA | KX_ECDSA + deriving (Show, Eq) diff --git a/Network/TLS/ErrT.hs b/Network/TLS/ErrT.hs --- a/Network/TLS/ErrT.hs +++ b/Network/TLS/ErrT.hs @@ -1,19 +1,13 @@ --- | --- Module : Network.TLS.ErrT --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- a simple compat ErrorT and other error stuff {-# LANGUAGE CPP #-} -module Network.TLS.ErrT - ( runErrT - , ErrT - , MonadError(..) - ) where -import Control.Monad.Except (MonadError(..)) +-- | A simple compat ErrorT and other error stuff +module Network.TLS.ErrT ( + runErrT, + ErrT, + MonadError (..), +) where + +import Control.Monad.Except (MonadError (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) runErrT :: ExceptT e m a -> m (Either e a) diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -1,245 +1,146 @@ -{-# LANGUAGE BangPatterns #-} --- | --- Module : Network.TLS.Extension --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- basic extensions are defined in RFC 6066 --- -module Network.TLS.Extension - ( Extension(..) - , supportedExtensions - , definedExtensions - -- all extensions ID supported - , extensionID_ServerName - , extensionID_MaxFragmentLength - , extensionID_SecureRenegotiation - , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_ExtendedMasterSecret - , extensionID_NegotiatedGroups - , extensionID_EcPointFormats - , extensionID_Heartbeat - , extensionID_SignatureAlgorithms - , extensionID_PreSharedKey - , extensionID_EarlyData - , extensionID_SupportedVersions - , extensionID_Cookie - , extensionID_PskKeyExchangeModes - , extensionID_CertificateAuthorities - , extensionID_OidFilters - , extensionID_PostHandshakeAuth - , extensionID_SignatureAlgorithmsCert - , extensionID_KeyShare - , extensionID_QuicTransportParameters +{-# 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(..) - , ExtendedMasterSecret(..) - , NegotiatedGroups(..) - , Group(..) - , EcPointFormatsSupported(..) - , EcPointFormat(..) - , SessionTicket(..) - , HeartBeat(..) - , HeartBeatMode(..) - , SignatureAlgorithms(..) - , SignatureAlgorithmsCert(..) - , SupportedVersions(..) - , KeyShare(..) - , KeyShareEntry(..) - , MessageType(..) - , PostHandshakeAuth(..) - , PskKexMode(..) - , PskKeyExchangeModes(..) - , PskIdentity(..) - , PreSharedKey(..) - , EarlyDataIndication(..) - , Cookie(..) - , CertificateAuthorities(..) - ) where + 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.Struct ( DistinguishedName - , ExtensionID - , EnumSafe8(..) - , EnumSafe16(..) - , HashAndSignatureAlgorithm ) import Network.TLS.Crypto.Types -import Network.TLS.Types (Version(..), HostName) +import Network.TLS.Struct +import Network.TLS.Types (HostName, Ticket) -import Network.TLS.Wire import Network.TLS.Imports -import Network.TLS.Packet ( putDNames - , getDNames - , putSignatureHashAlgorithm - , getSignatureHashAlgorithm - , putBinaryVersion - , getBinaryVersion - ) - ------------------------------------------------------------- - --- central list defined in -extensionID_ServerName - , extensionID_MaxFragmentLength - , extensionID_ClientCertificateUrl - , extensionID_TrustedCAKeys - , extensionID_TruncatedHMAC - , extensionID_StatusRequest - , extensionID_UserMapping - , extensionID_ClientAuthz - , extensionID_ServerAuthz - , extensionID_CertType - , extensionID_NegotiatedGroups - , extensionID_EcPointFormats - , extensionID_SRP - , extensionID_SignatureAlgorithms - , extensionID_SRTP - , extensionID_Heartbeat - , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_StatusRequestv2 - , extensionID_SignedCertificateTimestamp - , extensionID_ClientCertificateType - , extensionID_ServerCertificateType - , extensionID_Padding - , extensionID_EncryptThenMAC - , extensionID_ExtendedMasterSecret - , extensionID_SessionTicket - , extensionID_PreSharedKey - , extensionID_EarlyData - , extensionID_SupportedVersions - , extensionID_Cookie - , extensionID_PskKeyExchangeModes - , extensionID_CertificateAuthorities - , extensionID_OidFilters - , extensionID_PostHandshakeAuth - , extensionID_SignatureAlgorithmsCert - , extensionID_KeyShare - , extensionID_SecureRenegotiation - , extensionID_QuicTransportParameters :: ExtensionID -extensionID_ServerName = 0x0 -- RFC6066 -extensionID_MaxFragmentLength = 0x1 -- RFC6066 -extensionID_ClientCertificateUrl = 0x2 -- RFC6066 -extensionID_TrustedCAKeys = 0x3 -- RFC6066 -extensionID_TruncatedHMAC = 0x4 -- RFC6066 -extensionID_StatusRequest = 0x5 -- RFC6066 -extensionID_UserMapping = 0x6 -- RFC4681 -extensionID_ClientAuthz = 0x7 -- RFC5878 -extensionID_ServerAuthz = 0x8 -- RFC5878 -extensionID_CertType = 0x9 -- RFC6091 -extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 -extensionID_EcPointFormats = 0xb -- RFC4492 -extensionID_SRP = 0xc -- RFC5054 -extensionID_SignatureAlgorithms = 0xd -- RFC5246, TLS 1.3 -extensionID_SRTP = 0xe -- RFC5764 -extensionID_Heartbeat = 0xf -- RFC6520 -extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301 -extensionID_StatusRequestv2 = 0x11 -- RFC6961 -extensionID_SignedCertificateTimestamp = 0x12 -- RFC6962 -extensionID_ClientCertificateType = 0x13 -- RFC7250 -extensionID_ServerCertificateType = 0x14 -- RFC7250 -extensionID_Padding = 0x15 -- draft-agl-tls-padding. expires 2015-03-12 -extensionID_EncryptThenMAC = 0x16 -- RFC7366 -extensionID_ExtendedMasterSecret = 0x17 -- REF7627 -extensionID_SessionTicket = 0x23 -- RFC4507 --- Reserved 0x28 -- TLS 1.3 -extensionID_PreSharedKey = 0x29 -- TLS 1.3 -extensionID_EarlyData = 0x2a -- TLS 1.3 -extensionID_SupportedVersions = 0x2b -- TLS 1.3 -extensionID_Cookie = 0x2c -- TLS 1.3 -extensionID_PskKeyExchangeModes = 0x2d -- TLS 1.3 --- Reserved 0x2e -- TLS 1.3 -extensionID_CertificateAuthorities = 0x2f -- TLS 1.3 -extensionID_OidFilters = 0x30 -- TLS 1.3 -extensionID_PostHandshakeAuth = 0x31 -- TLS 1.3 -extensionID_SignatureAlgorithmsCert = 0x32 -- TLS 1.3 -extensionID_KeyShare = 0x33 -- TLS 1.3 -extensionID_QuicTransportParameters = 0x39 -- QUIC -extensionID_SecureRenegotiation = 0xff01 -- RFC5746 +import Network.TLS.Packet ( + getBinaryVersion, + getDNames, + getSignatureHashAlgorithm, + putBinaryVersion, + putDNames, + putSignatureHashAlgorithm, + ) +import Network.TLS.Wire ------------------------------------------------------------ definedExtensions :: [ExtensionID] definedExtensions = - [ extensionID_ServerName - , extensionID_MaxFragmentLength - , extensionID_ClientCertificateUrl - , extensionID_TrustedCAKeys - , extensionID_TruncatedHMAC - , extensionID_StatusRequest - , extensionID_UserMapping - , extensionID_ClientAuthz - , extensionID_ServerAuthz - , extensionID_CertType - , extensionID_NegotiatedGroups - , extensionID_EcPointFormats - , extensionID_SRP - , extensionID_SignatureAlgorithms - , extensionID_SRTP - , extensionID_Heartbeat - , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_StatusRequestv2 - , extensionID_SignedCertificateTimestamp - , extensionID_ClientCertificateType - , extensionID_ServerCertificateType - , extensionID_Padding - , extensionID_EncryptThenMAC - , extensionID_ExtendedMasterSecret - , extensionID_SessionTicket - , extensionID_PreSharedKey - , extensionID_EarlyData - , extensionID_SupportedVersions - , extensionID_Cookie - , extensionID_PskKeyExchangeModes - , extensionID_KeyShare - , extensionID_SignatureAlgorithmsCert - , extensionID_CertificateAuthorities - , extensionID_SecureRenegotiation - , extensionID_QuicTransportParameters + [ 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 = [ extensionID_ServerName - , extensionID_MaxFragmentLength - , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_ExtendedMasterSecret - , extensionID_SecureRenegotiation - , extensionID_NegotiatedGroups - , extensionID_EcPointFormats - , extensionID_SignatureAlgorithms - , extensionID_SignatureAlgorithmsCert - , extensionID_KeyShare - , extensionID_PreSharedKey - , extensionID_EarlyData - , extensionID_SupportedVersions - , extensionID_Cookie - , extensionID_PskKeyExchangeModes - , extensionID_CertificateAuthorities - , extensionID_QuicTransportParameters - ] +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) +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 + extensionID :: a -> ExtensionID extensionDecode :: MessageType -> ByteString -> Maybe a extensionEncode :: a -> ByteString @@ -248,21 +149,23 @@ -- | 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) +newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq) -data ServerNameType = ServerNameHostName HostName - | ServerNameOther (Word8, ByteString) - deriving (Show,Eq) +data ServerNameType + = ServerNameHostName HostName + | ServerNameOther (Word8, ByteString) + deriving (Show, Eq) instance Extension ServerName where - extensionID _ = extensionID_ServerName + 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 + 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" + extensionDecode _ = error "extensionDecode: ServerName" decodeServerName :: ByteString -> Maybe ServerName decodeServerName = runGetMaybe $ do @@ -270,13 +173,13 @@ ServerName <$> getList len getServerName where getServerName = do - ty <- getWord8 + ty <- getWord8 snameParsed <- getOpaque16 - let !sname = B.copy snameParsed + 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) + 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion + _ -> ServerNameOther (ty, sname) + return (1 + 2 + B.length sname, name) ------------------------------------------------------------ @@ -288,21 +191,23 @@ -- 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 MaxFragmentLength + = MaxFragmentLength MaxFragmentEnum + | MaxFragmentLengthOther Word8 + deriving (Show, Eq) -data MaxFragmentEnum = MaxFragment512 - | MaxFragment1024 - | MaxFragment2048 - | MaxFragment4096 - deriving (Show,Eq) +data MaxFragmentEnum + = MaxFragment512 + | MaxFragment1024 + | MaxFragment2048 + | MaxFragment4096 + deriving (Show, Eq) instance Extension MaxFragmentLength where - extensionID _ = extensionID_MaxFragmentLength + extensionID _ = EID_MaxFragmentLength extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l where - fromMaxFragmentEnum MaxFragment512 = 1 + fromMaxFragmentEnum MaxFragment512 = 1 fromMaxFragmentEnum MaxFragment1024 = 2 fromMaxFragmentEnum MaxFragment2048 = 3 fromMaxFragmentEnum MaxFragment4096 = 4 @@ -310,7 +215,7 @@ extensionDecode MsgTClientHello = decodeMaxFragmentLength extensionDecode MsgTServerHello = decodeMaxFragmentLength extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength - extensionDecode _ = error "extensionDecode: MaxFragmentLength" + extensionDecode _ = error "extensionDecode: MaxFragmentLength" decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8 @@ -324,312 +229,327 @@ ------------------------------------------------------------ -- | Secure Renegotiation -data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString) - deriving (Show,Eq) +data SecureRenegotiation = SecureRenegotiation ByteString ByteString + deriving (Show, Eq) instance Extension SecureRenegotiation where - extensionID _ = extensionID_SecureRenegotiation + extensionID _ = EID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = - runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty 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 (Just svd) - MsgTClientHello -> return $ SecureRenegotiation opaque Nothing - _ -> error "extensionDecode: SecureRenegotiation" + 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) +newtype ApplicationLayerProtocolNegotiation + = ApplicationLayerProtocolNegotiation [ByteString] + deriving (Show, Eq) instance Extension ApplicationLayerProtocolNegotiation where - extensionID _ = extensionID_ApplicationLayerProtocolNegotiation + 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" + extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" -decodeApplicationLayerProtocolNegotiation :: ByteString -> Maybe 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 + let alpn = B.copy alpnParsed return (B.length alpn + 1, alpn) ------------------------------------------------------------ --- | Extended Master Secret -data ExtendedMasterSecret = ExtendedMasterSecret deriving (Show,Eq) +-- | Extended Main Secret +data ExtendedMainSecret = ExtendedMainSecret deriving (Show, Eq) -instance Extension ExtendedMasterSecret where - extensionID _ = extensionID_ExtendedMasterSecret - extensionEncode ExtendedMasterSecret = B.empty - extensionDecode MsgTClientHello _ = Just ExtendedMasterSecret - extensionDecode MsgTServerHello _ = Just ExtendedMasterSecret - extensionDecode _ _ = error "extensionDecode: ExtendedMasterSecret" +instance Extension ExtendedMainSecret where + extensionID _ = EID_ExtendedMainSecret + extensionEncode ExtendedMainSecret = B.empty + extensionDecode MsgTClientHello _ = Just ExtendedMainSecret + extensionDecode MsgTServerHello _ = Just ExtendedMainSecret + extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret" ------------------------------------------------------------ -newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) +newtype SupportedGroups = SupportedGroups [Group] deriving (Show, Eq) -- on decode, filter all unknown curves -instance Extension NegotiatedGroups where - extensionID _ = extensionID_NegotiatedGroups - extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups - extensionDecode MsgTClientHello = decodeNegotiatedGroups - extensionDecode MsgTEncryptedExtensions = decodeNegotiatedGroups - extensionDecode _ = error "extensionDecode: NegotiatedGroups" +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" -decodeNegotiatedGroups :: ByteString -> Maybe NegotiatedGroups -decodeNegotiatedGroups = - runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16) +decodeSupportedGroups :: ByteString -> Maybe SupportedGroups +decodeSupportedGroups = + runGetMaybe (SupportedGroups . map Group <$> getWords16) ------------------------------------------------------------ -newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) +newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] + deriving (Show, Eq) -data EcPointFormat = - EcPointFormat_Uncompressed - | EcPointFormat_AnsiX962_compressed_prime - | EcPointFormat_AnsiX962_compressed_char2 - deriving (Show,Eq) +newtype EcPointFormat = EcPointFormat {fromEcPointFormat :: Word8} + deriving (Eq) -instance EnumSafe8 EcPointFormat where - fromEnumSafe8 EcPointFormat_Uncompressed = 0 - fromEnumSafe8 EcPointFormat_AnsiX962_compressed_prime = 1 - fromEnumSafe8 EcPointFormat_AnsiX962_compressed_char2 = 2 +{- 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 - toEnumSafe8 0 = Just EcPointFormat_Uncompressed - toEnumSafe8 1 = Just EcPointFormat_AnsiX962_compressed_prime - toEnumSafe8 2 = Just EcPointFormat_AnsiX962_compressed_char2 - toEnumSafe8 _ = Nothing +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 _ = extensionID_EcPointFormats - extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats + 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 . mapMaybe toEnumSafe8 <$> getWords8) + runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8) ------------------------------------------------------------ --- Fixme: this is incomplete --- newtype SessionTicket = SessionTicket ByteString -data SessionTicket = SessionTicket - deriving (Show,Eq) +newtype SessionTicket = SessionTicket Ticket + deriving (Show, Eq) +-- https://datatracker.ietf.org/doc/html/rfc5077#appendix-A instance Extension SessionTicket where - extensionID _ = extensionID_SessionTicket - extensionEncode SessionTicket{} = runPut $ return () - extensionDecode MsgTClientHello = runGetMaybe (return SessionTicket) - extensionDecode MsgTServerHello = runGetMaybe (return SessionTicket) - extensionDecode _ = error "extensionDecode: SessionTicket" + 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 HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq) -data HeartBeatMode = - HeartBeat_PeerAllowedToSend - | HeartBeat_PeerNotAllowedToSend - deriving (Show,Eq) +newtype HeartBeatMode = HeartBeatMode {fromHeartBeatMode :: Word8} + deriving (Eq) -instance EnumSafe8 HeartBeatMode where - fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1 - fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2 +{- FOURMOLU_DISABLE -} +pattern HeartBeat_PeerAllowedToSend :: HeartBeatMode +pattern HeartBeat_PeerAllowedToSend = HeartBeatMode 1 +pattern HeartBeat_PeerNotAllowedToSend :: HeartBeatMode +pattern HeartBeat_PeerNotAllowedToSend = HeartBeatMode 2 - toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend - toEnumSafe8 2 = Just HeartBeat_PeerNotAllowedToSend - toEnumSafe8 _ = Nothing +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 _ = extensionID_Heartbeat - extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode + extensionID _ = EID_Heartbeat + extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode extensionDecode MsgTClientHello = decodeHeartBeat extensionDecode MsgTServerHello = decodeHeartBeat - extensionDecode _ = error "extensionDecode: HeartBeat" + extensionDecode _ = error "extensionDecode: HeartBeat" decodeHeartBeat :: ByteString -> Maybe HeartBeat -decodeHeartBeat = runGetMaybe $ do - mm <- toEnumSafe8 <$> getWord8 - case mm of - Just m -> return $ HeartBeat m - Nothing -> fail "unknown HeartBeatMode" +decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8 ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) +newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] + deriving (Show, Eq) instance Extension SignatureAlgorithms where - extensionID _ = extensionID_SignatureAlgorithms + extensionID _ = EID_SignatureAlgorithms extensionEncode (SignatureAlgorithms algs) = - runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs + runPut $ + putWord16 (fromIntegral (length algs * 2)) + >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithms extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms - extensionDecode _ = error "extensionDecode: SignatureAlgorithms" + extensionDecode _ = error "extensionDecode: SignatureAlgorithms" decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms decodeSignatureAlgorithms = runGetMaybe $ do len <- getWord16 - sas <- getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + 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) +data PostHandshakeAuth = PostHandshakeAuth deriving (Show, Eq) instance Extension PostHandshakeAuth where - extensionID _ = extensionID_PostHandshakeAuth - extensionEncode _ = B.empty + extensionID _ = EID_PostHandshakeAuth + extensionEncode _ = B.empty extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth - extensionDecode _ = error "extensionDecode: PostHandshakeAuth" + extensionDecode _ = error "extensionDecode: PostHandshakeAuth" ------------------------------------------------------------ -newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] deriving (Show,Eq) +newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] + deriving (Show, Eq) instance Extension SignatureAlgorithmsCert where - extensionID _ = extensionID_SignatureAlgorithmsCert + extensionID _ = EID_SignatureAlgorithmsCert extensionEncode (SignatureAlgorithmsCert algs) = - runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs + runPut $ + putWord16 (fromIntegral (length algs * 2)) + >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert - extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" + extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert" decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert decodeSignatureAlgorithmsCert = runGetMaybe $ do len <- getWord16 - SignatureAlgorithmsCert <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + SignatureAlgorithmsCert + <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) ------------------------------------------------------------ -data SupportedVersions = - SupportedVersionsClientHello [Version] - | SupportedVersionsServerHello Version - deriving (Show,Eq) +data SupportedVersions + = SupportedVersionsClientHello [Version] + | SupportedVersionsServerHello Version + deriving (Show, Eq) instance Extension SupportedVersions where - extensionID _ = extensionID_SupportedVersions + extensionID _ = EID_SupportedVersions extensionEncode (SupportedVersionsClientHello vers) = runPut $ do putWord8 (fromIntegral (length vers * 2)) mapM_ putBinaryVersion vers - extensionEncode (SupportedVersionsServerHello ver) = runPut $ - putBinaryVersion ver + extensionEncode (SupportedVersionsServerHello ver) = + runPut $ + putBinaryVersion ver extensionDecode MsgTClientHello = runGetMaybe $ do len <- fromIntegral <$> getWord8 - SupportedVersionsClientHello . catMaybes <$> getList len getVer + SupportedVersionsClientHello <$> getList len getVer where getVer = do ver <- getBinaryVersion - return (2,ver) - extensionDecode MsgTServerHello = runGetMaybe $ do - mver <- getBinaryVersion - case mver of - Just ver -> return $ SupportedVersionsServerHello ver - Nothing -> fail "extensionDecode: SupportedVersionsServerHello" + return (2, ver) + extensionDecode MsgTServerHello = + runGetMaybe (SupportedVersionsServerHello <$> getBinaryVersion) extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello" ------------------------------------------------------------ -data KeyShareEntry = KeyShareEntry { - keyShareEntryGroup :: Group - , keyShareEntryKeyExchange :: ByteString - } deriving (Show,Eq) +data KeyShareEntry = KeyShareEntry + { keyShareEntryGroup :: Group + , keyShareEntryKeyExchange :: ByteString + } + deriving (Show, Eq) getKeyShareEntry :: Get (Int, Maybe KeyShareEntry) getKeyShareEntry = do - g <- getWord16 + grp <- Group <$> getWord16 l <- fromIntegral <$> getWord16 key <- getBytes l - let !len = l + 4 - case toEnumSafe16 g of - Nothing -> return (len, Nothing) - Just grp -> return (len, Just $ KeyShareEntry grp key) + let len = l + 4 + return (len, Just $ KeyShareEntry grp key) putKeyShareEntry :: KeyShareEntry -> Put -putKeyShareEntry (KeyShareEntry grp key) = do - putWord16 $ fromEnumSafe16 grp +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) +data KeyShare + = KeyShareClientHello [KeyShareEntry] + | KeyShareServerHello KeyShareEntry + | KeyShareHRR Group + deriving (Show, Eq) instance Extension KeyShare where - extensionID _ = extensionID_KeyShare + extensionID _ = EID_KeyShare extensionEncode (KeyShareClientHello kses) = runPut $ do - let !len = sum [B.length key + 4 | KeyShareEntry _ key <- kses] + let len = sum [B.length key + 4 | KeyShareEntry _ key <- kses] putWord16 $ fromIntegral len mapM_ putKeyShareEntry kses extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse - extensionEncode (KeyShareHRR grp) = runPut $ putWord16 $ fromEnumSafe16 grp - extensionDecode MsgTServerHello = runGetMaybe $ do + extensionEncode (KeyShareHRR (Group grp)) = runPut $ putWord16 grp + extensionDecode MsgTServerHello = runGetMaybe $ do (_, ment) <- getKeyShareEntry case ment of - Nothing -> fail "decoding KeyShare for ServerHello" + Nothing -> fail "decoding KeyShare for ServerHello" Just ent -> return $ KeyShareServerHello ent extensionDecode MsgTClientHello = runGetMaybe $ do len <- fromIntegral <$> getWord16 --- len == 0 allows for HRR + -- len == 0 allows for HRR grps <- getList len getKeyShareEntry return $ KeyShareClientHello $ catMaybes grps - extensionDecode MsgTHelloRetryRequest = runGetMaybe $ do - mgrp <- toEnumSafe16 <$> getWord16 - case mgrp of - Nothing -> fail "decoding KeyShare for HRR" - Just grp -> return $ KeyShareHRR grp + extensionDecode MsgTHelloRetryRequest = + runGetMaybe $ + KeyShareHRR . Group <$> getWord16 extensionDecode _ = error "extensionDecode: KeyShare" ------------------------------------------------------------ -data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show) +newtype PskKexMode = PskKexMode {fromPskKexMode :: Word8} deriving (Eq) -instance EnumSafe8 PskKexMode where - fromEnumSafe8 PSK_KE = 0 - fromEnumSafe8 PSK_DHE_KE = 1 +{- FOURMOLU_DISABLE -} +pattern PSK_KE :: PskKexMode +pattern PSK_KE = PskKexMode 0 +pattern PSK_DHE_KE :: PskKexMode +pattern PSK_DHE_KE = PskKexMode 1 - toEnumSafe8 0 = Just PSK_KE - toEnumSafe8 1 = Just PSK_DHE_KE - toEnumSafe8 _ = Nothing +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) +newtype PskKeyExchangeModes = PskKeyExchangeModes [PskKexMode] + deriving (Eq, Show) instance Extension PskKeyExchangeModes where - extensionID _ = extensionID_PskKeyExchangeModes - extensionEncode (PskKeyExchangeModes pkms) = runPut $ - putWords8 $ map fromEnumSafe8 pkms - extensionDecode MsgTClientHello = runGetMaybe $ - PskKeyExchangeModes . mapMaybe toEnumSafe8 <$> getWords8 + 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) +data PreSharedKey + = PreSharedKeyClientHello [PskIdentity] [ByteString] + | PreSharedKeyServerHello Int + deriving (Eq, Show) instance Extension PreSharedKey where - extensionID _ = extensionID_PreSharedKey + extensionID _ = EID_PreSharedKey extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do putOpaque16 $ runPut (mapM_ putIdentity ids) putOpaque16 $ runPut (mapM_ putBinder bds) @@ -638,10 +558,13 @@ putOpaque16 bs putWord32 w putBinder = putOpaque8 - extensionEncode (PreSharedKeyServerHello w16) = runPut $ - putWord16 $ fromIntegral w16 - extensionDecode MsgTServerHello = runGetMaybe $ - PreSharedKeyServerHello . fromIntegral <$> getWord16 + extensionEncode (PreSharedKeyServerHello w16) = + runPut $ + putWord16 $ + fromIntegral w16 + extensionDecode MsgTServerHello = + runGetMaybe $ + PreSharedKeyServerHello . fromIntegral <$> getWord16 extensionDecode MsgTClientHello = runGetMaybe $ do len1 <- fromIntegral <$> getWord16 identities <- getList len1 getIdentity @@ -663,27 +586,29 @@ ------------------------------------------------------------ -newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32) deriving (Eq, Show) +newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32) + deriving (Eq, Show) instance Extension EarlyDataIndication where - extensionID _ = extensionID_EarlyData - extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty + extensionID _ = EID_EarlyData + extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32 - extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) + extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing) - extensionDecode MsgTNewSessionTicket = runGetMaybe $ - EarlyDataIndication . Just <$> getWord32 - extensionDecode _ = error "extensionDecode: EarlyDataIndication" + extensionDecode MsgTNewSessionTicket = + runGetMaybe $ + EarlyDataIndication . Just <$> getWord32 + extensionDecode _ = error "extensionDecode: EarlyDataIndication" ------------------------------------------------------------ newtype Cookie = Cookie ByteString deriving (Eq, Show) instance Extension Cookie where - extensionID _ = extensionID_Cookie + extensionID _ = EID_Cookie extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16) - extensionDecode _ = error "extensionDecode: Cookie" + extensionDecode _ = error "extensionDecode: Cookie" ------------------------------------------------------------ @@ -691,11 +616,12 @@ deriving (Eq, Show) instance Extension CertificateAuthorities where - extensionID _ = extensionID_CertificateAuthorities - extensionEncode (CertificateAuthorities names) = runPut $ - putDNames names + extensionID _ = EID_CertificateAuthorities + extensionEncode (CertificateAuthorities names) = + runPut $ + putDNames names extensionDecode MsgTClientHello = - runGetMaybe (CertificateAuthorities <$> getDNames) + runGetMaybe (CertificateAuthorities <$> getDNames) extensionDecode MsgTCertificateRequest = - runGetMaybe (CertificateAuthorities <$> getDNames) + runGetMaybe (CertificateAuthorities <$> getDNames) extensionDecode _ = error "extensionDecode: CertificateAuthorities" diff --git a/Network/TLS/Extra.hs b/Network/TLS/Extra.hs --- a/Network/TLS/Extra.hs +++ b/Network/TLS/Extra.hs @@ -1,15 +1,8 @@ --- | --- Module : Network.TLS.Extra --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- default values and ciphers -module Network.TLS.Extra - ( module Network.TLS.Extra.Cipher - , module Network.TLS.Extra.FFDHE - ) where +-- | Default values and ciphers +module Network.TLS.Extra ( + module Network.TLS.Extra.Cipher, + module Network.TLS.Extra.FFDHE, +) where import Network.TLS.Extra.Cipher import Network.TLS.Extra.FFDHE diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -1,1156 +1,585 @@ --- | --- Module : Network.TLS.Extra.Cipher --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Extra.Cipher - ( - -- * cipher suite - ciphersuite_default - , ciphersuite_default_det - , ciphersuite_all - , ciphersuite_all_det - , ciphersuite_medium - , ciphersuite_strong - , ciphersuite_strong_det - , ciphersuite_unencrypted - , ciphersuite_dhe_rsa - , ciphersuite_dhe_dss - -- * individual ciphers - , cipher_null_SHA1 - , cipher_AES128_SHA1 - , cipher_AES256_SHA1 - , cipher_AES128_SHA256 - , cipher_AES256_SHA256 - , cipher_AES128CCM_SHA256 - , cipher_AES128CCM8_SHA256 - , cipher_AES128GCM_SHA256 - , cipher_AES256CCM_SHA256 - , cipher_AES256CCM8_SHA256 - , cipher_AES256GCM_SHA384 - , cipher_DHE_RSA_AES128_SHA1 - , cipher_DHE_RSA_AES256_SHA1 - , cipher_DHE_RSA_AES128_SHA256 - , cipher_DHE_RSA_AES256_SHA256 - , cipher_DHE_DSS_AES128_SHA1 - , cipher_DHE_DSS_AES256_SHA1 - , cipher_DHE_RSA_AES128CCM_SHA256 - , cipher_DHE_RSA_AES128CCM8_SHA256 - , cipher_DHE_RSA_AES128GCM_SHA256 - , cipher_DHE_RSA_AES256CCM_SHA256 - , cipher_DHE_RSA_AES256CCM8_SHA256 - , cipher_DHE_RSA_AES256GCM_SHA384 - , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 - , cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA256 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_ECDHE_RSA_AES256CBC_SHA - , cipher_ECDHE_RSA_AES256CBC_SHA384 - , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 - , cipher_ECDHE_ECDSA_AES128CBC_SHA - , cipher_ECDHE_ECDSA_AES256CBC_SHA - , cipher_ECDHE_ECDSA_AES128CBC_SHA256 - , cipher_ECDHE_ECDSA_AES256CBC_SHA384 - , 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 - , cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES256GCM_SHA384 - , cipher_TLS13_CHACHA20POLY1305_SHA256 - , cipher_TLS13_AES128CCM_SHA256 - , cipher_TLS13_AES128CCM8_SHA256 - -- * obsolete and non-standard ciphers - , cipher_RSA_3DES_EDE_CBC_SHA1 - , cipher_RC4_128_MD5 - , cipher_RC4_128_SHA1 - , cipher_null_MD5 - , cipher_DHE_DSS_RC4_SHA1 - ) where - -import qualified Data.ByteString as B - -import Network.TLS.Types (Version(..)) -import Network.TLS.Cipher -import Network.TLS.Imports -import Data.Tuple (swap) - -import Crypto.Cipher.AES -import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 -import qualified Crypto.Cipher.RC4 as RC4 -import Crypto.Cipher.TripleDES -import Crypto.Cipher.Types hiding (Cipher, cipherName) -import Crypto.Error -import qualified Crypto.MAC.Poly1305 as Poly1305 -import Crypto.System.CPU - -takelast :: Int -> B.ByteString -> B.ByteString -takelast i b = B.drop (B.length b - i) b - -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)) - -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 - -makeIV_ :: BlockCipher a => B.ByteString -> IV a -makeIV_ = fromMaybe (error "makeIV_") . makeIV - -tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock -tripledes_ede BulkEncrypt key = - let ctx = noFail $ cipherInit key - in (\iv input -> let output = cbcEncrypt ctx (tripledes_iv iv) input in (output, takelast 8 output)) -tripledes_ede BulkDecrypt key = - let ctx = noFail $ cipherInit key - in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input)) - -tripledes_iv :: BulkIV -> IV DES_EDE3 -tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv - -rc4 :: BulkDirection -> BulkKey -> BulkStream -rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey) - where - combineRC4 ctx input = - let (ctx', output) = RC4.combine ctx input - in (output, BulkStream (combineRC4 ctx')) - -chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD -chacha20poly1305 BulkEncrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in (\input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.encrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag)) -chacha20poly1305 BulkDecrypt key nonce = - let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in (\input ad -> - let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) - (output, st3) = ChaChaPoly1305.decrypt input st2 - Poly1305.Auth tag = ChaChaPoly1305.finalize st3 - in (output, AuthTag tag)) - -data CipherSet - = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm - | SetOther [Cipher] - --- Preference between AEAD ciphers having equivalent properties is based on --- hardware-acceleration support in the crypton implementation. -sortOptimized :: [CipherSet] -> [Cipher] -sortOptimized = concatMap f - where - f (SetAead gcm chacha ccm) - | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm - | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm - | otherwise = gcm ++ ccm ++ chacha - f (SetOther ciphers) = ciphers - --- Order which is deterministic but not optimized for the CPU. -sortDeterministic :: [CipherSet] -> [Cipher] -sortDeterministic = concatMap f - where - f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm - f (SetOther ciphers) = ciphers - --- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to --- weak. This choice of ciphersuites should satisfy most normal needs. For --- otherwise strong ciphers we make little distinction between AES128 and --- AES256, and list each but the weakest of the AES128 ciphers ahead of the --- corresponding AES256 ciphers. --- --- AEAD ciphers with equivalent security properties are ordered based on CPU --- hardware-acceleration support. If this dynamic runtime behavior is not --- desired, use 'ciphersuite_default_det' instead. -ciphersuite_default :: [Cipher] -ciphersuite_default = sortOptimized sets_default - --- | 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 ] - [] - , SetAead - [ cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384 ] - [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ] - [ cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 ] - -- Next the PFS + CBC + SHA2 ciphers - , SetOther - [ 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 - ] - -- Next the PFS + CBC + SHA1 ciphers - , SetOther - [ cipher_ECDHE_ECDSA_AES128CBC_SHA, cipher_ECDHE_ECDSA_AES256CBC_SHA - , cipher_ECDHE_RSA_AES128CBC_SHA, cipher_ECDHE_RSA_AES256CBC_SHA - , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1 - ] - -- Next the non-PFS + AEAD + SHA2 ciphers - , SetAead - [ cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384 ] - [] - [ cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256 ] - -- Next the non-PFS + CBC + SHA2 ciphers - , SetOther [ cipher_AES256_SHA256, cipher_AES128_SHA256 ] - -- Next the non-PFS + CBC + SHA1 ciphers - , SetOther [ cipher_AES256_SHA1, cipher_AES128_SHA1 ] - -- Nobody uses or should use DSS, RC4, 3DES or MD5 --- , SetOther --- [ cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 --- , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 --- , cipher_RSA_3DES_EDE_CBC_SHA1 --- ] - -- 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 ] - ] - -{-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} --- | The default ciphersuites + some not recommended last resort ciphers. --- --- AEAD ciphers with equivalent security properties are ordered based on CPU --- hardware-acceleration support. If this dynamic runtime behavior is not --- desired, use 'ciphersuite_all_det' instead. -ciphersuite_all :: [Cipher] -ciphersuite_all = ciphersuite_default ++ complement_all - -{-# WARNING ciphersuite_all_det "This ciphersuite list contains RC4. Use ciphersuite_strong_det or ciphersuite_default_det instead." #-} --- | Same as 'ciphersuite_all', but using deterministic preference not --- influenced by the CPU. -ciphersuite_all_det :: [Cipher] -ciphersuite_all_det = ciphersuite_default_det ++ complement_all - -complement_all :: [Cipher] -complement_all = - [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256, cipher_ECDHE_ECDSA_AES256CCM8_SHA256 - , cipher_DHE_RSA_AES128CCM8_SHA256, cipher_DHE_RSA_AES256CCM8_SHA256 - , cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1 - , cipher_AES128CCM8_SHA256, cipher_AES256CCM8_SHA256 - , cipher_RSA_3DES_EDE_CBC_SHA1 - , cipher_RC4_128_SHA1 - , cipher_TLS13_AES128CCM8_SHA256 - ] - -{-# DEPRECATED ciphersuite_medium "Use ciphersuite_strong or ciphersuite_default instead." #-} --- | list of medium ciphers. -ciphersuite_medium :: [Cipher] -ciphersuite_medium = [ cipher_RC4_128_SHA1 - , cipher_AES128_SHA1 - ] - --- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we --- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305 --- variants. For weaker constructs, we use just the AES256 form. --- --- AEAD ciphers with equivalent security properties are ordered based on CPU --- hardware-acceleration support. If this dynamic runtime behavior is not --- desired, use 'ciphersuite_strong_det' instead. -ciphersuite_strong :: [Cipher] -ciphersuite_strong = sortOptimized sets_strong - --- | Same as 'ciphersuite_strong', but using deterministic preference not --- influenced by the CPU. -ciphersuite_strong_det :: [Cipher] -ciphersuite_strong_det = sortDeterministic sets_strong - -sets_strong :: [CipherSet] -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 ] - , SetAead [ cipher_ECDHE_ECDSA_AES128GCM_SHA256 ] - [] - [ cipher_ECDHE_ECDSA_AES128CCM_SHA256 ] - , SetAead [ cipher_ECDHE_RSA_AES256GCM_SHA384 ] - [ cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 ] - [] - , SetAead [ cipher_ECDHE_RSA_AES128GCM_SHA256 ] - [] - [] - , SetAead [ cipher_DHE_RSA_AES256GCM_SHA384 ] - [ cipher_DHE_RSA_CHACHA20POLY1305_SHA256 ] - [ cipher_DHE_RSA_AES256CCM_SHA256 ] - , SetAead [ cipher_DHE_RSA_AES128GCM_SHA256 ] - [] - [ cipher_DHE_RSA_AES128CCM_SHA256 ] - -- No AEAD - , SetOther - [ cipher_ECDHE_ECDSA_AES256CBC_SHA384 - , cipher_ECDHE_RSA_AES256CBC_SHA384 - , cipher_DHE_RSA_AES256_SHA256 - ] - -- No SHA2 - , SetOther - [ cipher_ECDHE_ECDSA_AES256CBC_SHA - , cipher_ECDHE_RSA_AES256CBC_SHA - , cipher_DHE_RSA_AES256_SHA1 - ] - -- No PFS - , SetAead [ cipher_AES256GCM_SHA384 ] - [] - [ cipher_AES256CCM_SHA256 ] - -- Neither PFS nor AEAD, just SHA2 - , SetOther [ cipher_AES256_SHA256 ] - -- Last resort no PFS, AEAD or SHA2 - , SetOther [ cipher_AES256_SHA1 ] - -- TLS13 (listed at the end but version is negotiated first) - , SetAead [ cipher_TLS13_AES256GCM_SHA384 ] - [ cipher_TLS13_CHACHA20POLY1305_SHA256 ] - [] - , SetAead [ cipher_TLS13_AES128GCM_SHA256 ] - [] - [ cipher_TLS13_AES128CCM_SHA256 ] - ] - --- | DHE-RSA cipher suite. This only includes ciphers bound specifically to --- DHE-RSA so TLS 1.3 ciphers must be added separately. -ciphersuite_dhe_rsa :: [Cipher] -ciphersuite_dhe_rsa = [ cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES256CCM_SHA256 - , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 - , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES128CCM_SHA256 - , cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256 - , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1 - ] - -ciphersuite_dhe_dss :: [Cipher] -ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1] - --- | all unencrypted ciphers, do not use on insecure network. -ciphersuite_unencrypted :: [Cipher] -ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] - -bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede, bulk_aes128gcm, bulk_aes256gcm :: Bulk -bulk_aes128ccm, bulk_aes128ccm8, bulk_aes256ccm, bulk_aes256ccm8, bulk_chacha20poly1305 :: Bulk -bulk_null = Bulk - { bulkName = "null" - , bulkKeySize = 0 - , bulkIVSize = 0 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF passThrough - } - where - passThrough _ _ = BulkStream go where go inp = (inp, BulkStream go) - -bulk_rc4 = Bulk - { bulkName = "RC4-128" - , bulkKeySize = 16 - , bulkIVSize = 0 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 0 - , bulkF = BulkStreamF rc4 - } - -bulk_aes128 = Bulk - { bulkName = "AES128" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes128cbc - } - -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 - { 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 - { 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 - { 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 - { 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 - { 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_aes256 = Bulk - { bulkName = "AES256" - , bulkKeySize = 32 - , bulkIVSize = 16 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 16 - , bulkF = BulkBlockF aes256cbc - } - -bulk_tripledes_ede = Bulk - { bulkName = "3DES-EDE-CBC" - , bulkKeySize = 24 - , bulkIVSize = 8 - , bulkExplicitIV = 0 - , bulkAuthTagLen = 0 - , bulkBlockSize = 8 - , bulkF = BulkBlockF tripledes_ede - } - -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_aes256gcm_13, bulk_aes128ccm_13, bulk_aes128ccm8_13 :: Bulk -bulk_aes128gcm_13 = bulk_aes128gcm { bulkIVSize = 12, bulkExplicitIV = 0 } -bulk_aes256gcm_13 = bulk_aes256gcm { bulkIVSize = 12, bulkExplicitIV = 0 } -bulk_aes128ccm_13 = bulk_aes128ccm { bulkIVSize = 12, bulkExplicitIV = 0 } -bulk_aes128ccm8_13 = bulk_aes128ccm8 { bulkIVSize = 12, bulkExplicitIV = 0 } - --- | unencrypted cipher using RSA for key exchange and MD5 for digest -cipher_null_MD5 :: Cipher -cipher_null_MD5 = Cipher - { cipherID = 0x0001 - , cipherName = "RSA-null-MD5" - , cipherBulk = bulk_null - , cipherHash = MD5 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - --- | unencrypted cipher using RSA for key exchange and SHA1 for digest -cipher_null_SHA1 :: Cipher -cipher_null_SHA1 = Cipher - { cipherID = 0x0002 - , cipherName = "RSA-null-SHA1" - , cipherBulk = bulk_null - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - --- | RC4 cipher, RSA key exchange and MD5 for digest -cipher_RC4_128_MD5 :: Cipher -cipher_RC4_128_MD5 = Cipher - { cipherID = 0x0004 - , cipherName = "RSA-rc4-128-md5" - , cipherBulk = bulk_rc4 - , cipherHash = MD5 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - --- | RC4 cipher, RSA key exchange and SHA1 for digest -cipher_RC4_128_SHA1 :: Cipher -cipher_RC4_128_SHA1 = Cipher - { cipherID = 0x0005 - , cipherName = "RSA-rc4-128-sha1" - , cipherBulk = bulk_rc4 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - --- | 3DES cipher (168 bit key), RSA key exchange and SHA1 for digest -cipher_RSA_3DES_EDE_CBC_SHA1 :: Cipher -cipher_RSA_3DES_EDE_CBC_SHA1 = Cipher - { cipherID = 0x000A - , cipherName = "RSA-3DES-EDE-CBC-SHA1" - , cipherBulk = bulk_tripledes_ede - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Nothing - } - --- | AES cipher (128 bit key), RSA key exchange and SHA1 for digest -cipher_AES128_SHA1 :: Cipher -cipher_AES128_SHA1 = Cipher - { cipherID = 0x002F - , cipherName = "RSA-AES128-SHA1" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } - --- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest -cipher_DHE_DSS_AES128_SHA1 :: Cipher -cipher_DHE_DSS_AES128_SHA1 = Cipher - { cipherID = 0x0032 - , cipherName = "DHE-DSA-AES128-SHA1" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_DHE_DSS - , cipherMinVer = Nothing - } - --- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest -cipher_DHE_RSA_AES128_SHA1 :: Cipher -cipher_DHE_RSA_AES128_SHA1 = Cipher - { cipherID = 0x0033 - , cipherName = "DHE-RSA-AES128-SHA1" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Nothing - } - --- | AES cipher (256 bit key), RSA key exchange and SHA1 for digest -cipher_AES256_SHA1 :: Cipher -cipher_AES256_SHA1 = Cipher - { cipherID = 0x0035 - , cipherName = "RSA-AES256-SHA1" - , cipherBulk = bulk_aes256 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just SSL3 - } - --- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest -cipher_DHE_DSS_AES256_SHA1 :: Cipher -cipher_DHE_DSS_AES256_SHA1 = cipher_DHE_DSS_AES128_SHA1 - { cipherID = 0x0038 - , cipherName = "DHE-DSA-AES256-SHA1" - , cipherBulk = bulk_aes256 - } - --- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest -cipher_DHE_RSA_AES256_SHA1 :: Cipher -cipher_DHE_RSA_AES256_SHA1 = cipher_DHE_RSA_AES128_SHA1 - { cipherID = 0x0039 - , cipherName = "DHE-RSA-AES256-SHA1" - , cipherBulk = bulk_aes256 - } - --- | AES cipher (128 bit key), RSA key exchange and SHA256 for digest -cipher_AES128_SHA256 :: Cipher -cipher_AES128_SHA256 = Cipher - { cipherID = 0x003C - , cipherName = "RSA-AES128-SHA256" - , cipherBulk = bulk_aes128 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } - --- | AES cipher (256 bit key), RSA key exchange and SHA256 for digest -cipher_AES256_SHA256 :: Cipher -cipher_AES256_SHA256 = Cipher - { cipherID = 0x003D - , cipherName = "RSA-AES256-SHA256" - , cipherBulk = bulk_aes256 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } - --- This is not registered in IANA. --- So, this will be removed in the next major release. -cipher_DHE_DSS_RC4_SHA1 :: Cipher -cipher_DHE_DSS_RC4_SHA1 = cipher_DHE_DSS_AES128_SHA1 - { cipherID = 0x0066 - , cipherName = "DHE-DSA-RC4-SHA1" - , cipherBulk = bulk_rc4 - } - -cipher_DHE_RSA_AES128_SHA256 :: Cipher -cipher_DHE_RSA_AES128_SHA256 = cipher_DHE_RSA_AES128_SHA1 - { cipherID = 0x0067 - , cipherName = "DHE-RSA-AES128-SHA256" - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherMinVer = Just TLS12 - } - -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 - } - --- | AESCCM cipher (128 bit key), RSA key exchange. --- The SHA256 digest is used as a PRF, not as a MAC. -cipher_AES128CCM_SHA256 :: Cipher -cipher_AES128CCM_SHA256 = Cipher - { cipherID = 0xc09c - , cipherName = "RSA-AES128CCM-SHA256" - , cipherBulk = bulk_aes128ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - --- | AESCCM8 cipher (128 bit key), RSA key exchange. --- The SHA256 digest is used as a PRF, not as a MAC. -cipher_AES128CCM8_SHA256 :: Cipher -cipher_AES128CCM8_SHA256 = Cipher - { cipherID = 0xc0a0 - , cipherName = "RSA-AES128CCM8-SHA256" - , cipherBulk = bulk_aes128ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - --- | AESGCM cipher (128 bit key), RSA key exchange. --- The SHA256 digest is used as a PRF, not as a MAC. -cipher_AES128GCM_SHA256 :: Cipher -cipher_AES128GCM_SHA256 = Cipher - { cipherID = 0x009C - , cipherName = "RSA-AES128GCM-SHA256" - , cipherBulk = bulk_aes128gcm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } - --- | AESCCM cipher (256 bit key), RSA key exchange. --- The SHA256 digest is used as a PRF, not as a MAC. -cipher_AES256CCM_SHA256 :: Cipher -cipher_AES256CCM_SHA256 = Cipher - { cipherID = 0xc09d - , cipherName = "RSA-AES256CCM-SHA256" - , cipherBulk = bulk_aes256ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - --- | AESCCM8 cipher (256 bit key), RSA key exchange. --- The SHA256 digest is used as a PRF, not as a MAC. -cipher_AES256CCM8_SHA256 :: Cipher -cipher_AES256CCM8_SHA256 = Cipher - { cipherID = 0xc0a1 - , cipherName = "RSA-AES256CCM8-SHA256" - , cipherBulk = bulk_aes256ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - --- | AESGCM cipher (256 bit key), RSA key exchange. --- The SHA384 digest is used as a PRF, not as a MAC. -cipher_AES256GCM_SHA384 :: Cipher -cipher_AES256GCM_SHA384 = Cipher - { cipherID = 0x009D - , cipherName = "RSA-AES256GCM-SHA384" - , cipherBulk = bulk_aes256gcm - , cipherHash = SHA384 - , cipherPRFHash = Just SHA384 - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherMinVer = Just TLS12 - } - -cipher_DHE_RSA_AES128CCM_SHA256 :: Cipher -cipher_DHE_RSA_AES128CCM_SHA256 = Cipher - { cipherID = 0xc09e - , cipherName = "DHE-RSA-AES128CCM-SHA256" - , cipherBulk = bulk_aes128ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - -cipher_DHE_RSA_AES128CCM8_SHA256 :: Cipher -cipher_DHE_RSA_AES128CCM8_SHA256 = Cipher - { cipherID = 0xc0a2 - , cipherName = "DHE-RSA-AES128CCM8-SHA256" - , cipherBulk = bulk_aes128ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - -cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher -cipher_DHE_RSA_AES128GCM_SHA256 = Cipher - { cipherID = 0x009E - , cipherName = "DHE-RSA-AES128GCM-SHA256" - , cipherBulk = bulk_aes128gcm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 - } - -cipher_DHE_RSA_AES256CCM_SHA256 :: Cipher -cipher_DHE_RSA_AES256CCM_SHA256 = Cipher - { cipherID = 0xc09f - , cipherName = "DHE-RSA-AES256CCM-SHA256" - , cipherBulk = bulk_aes256ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - -cipher_DHE_RSA_AES256CCM8_SHA256 :: Cipher -cipher_DHE_RSA_AES256CCM8_SHA256 = Cipher - { cipherID = 0xc0a3 - , cipherName = "DHE-RSA-AES256CCM8-SHA256" - , cipherBulk = bulk_aes256ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3 - } - -cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher -cipher_DHE_RSA_AES256GCM_SHA384 = Cipher - { cipherID = 0x009F - , cipherName = "DHE-RSA-AES256GCM-SHA384" - , cipherBulk = bulk_aes256gcm - , cipherHash = SHA384 - , cipherPRFHash = Just SHA384 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 - } - -cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = Cipher - { cipherID = 0xCCA8 - , cipherName = "ECDHE-RSA-CHACHA20POLY1305-SHA256" - , cipherBulk = bulk_chacha20poly1305 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherMinVer = Just TLS12 - } - -cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = Cipher - { cipherID = 0xCCA9 - , cipherName = "ECDHE-ECDSA-CHACHA20POLY1305-SHA256" - , cipherBulk = bulk_chacha20poly1305 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 - } - -cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher -cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = Cipher - { cipherID = 0xCCAA - , cipherName = "DHE-RSA-CHACHA20POLY1305-SHA256" - , cipherBulk = bulk_chacha20poly1305 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_DHE_RSA - , cipherMinVer = Just TLS12 - } - -cipher_TLS13_AES128GCM_SHA256 :: Cipher -cipher_TLS13_AES128GCM_SHA256 = Cipher - { cipherID = 0x1301 - , cipherName = "AES128GCM-SHA256" - , cipherBulk = bulk_aes128gcm_13 - , cipherHash = SHA256 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_TLS13 - , cipherMinVer = Just TLS13 - } - -cipher_TLS13_AES256GCM_SHA384 :: Cipher -cipher_TLS13_AES256GCM_SHA384 = Cipher - { cipherID = 0x1302 - , cipherName = "AES256GCM-SHA384" - , cipherBulk = bulk_aes256gcm_13 - , cipherHash = SHA384 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_TLS13 - , cipherMinVer = Just TLS13 - } - -cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher -cipher_TLS13_CHACHA20POLY1305_SHA256 = Cipher - { cipherID = 0x1303 - , cipherName = "CHACHA20POLY1305-SHA256" - , cipherBulk = bulk_chacha20poly1305 - , cipherHash = SHA256 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_TLS13 - , cipherMinVer = Just TLS13 - } - -cipher_TLS13_AES128CCM_SHA256 :: Cipher -cipher_TLS13_AES128CCM_SHA256 = Cipher - { cipherID = 0x1304 - , cipherName = "AES128CCM-SHA256" - , cipherBulk = bulk_aes128ccm_13 - , cipherHash = SHA256 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_TLS13 - , cipherMinVer = Just TLS13 - } - -cipher_TLS13_AES128CCM8_SHA256 :: Cipher -cipher_TLS13_AES128CCM8_SHA256 = Cipher - { cipherID = 0x1305 - , cipherName = "AES128CCM8-SHA256" - , cipherBulk = bulk_aes128ccm8_13 - , cipherHash = SHA256 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_TLS13 - , cipherMinVer = Just TLS13 - } - -cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher -cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher - { cipherID = 0xC009 - , cipherName = "ECDHE-ECDSA-AES128CBC-SHA" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS10 - } - -cipher_ECDHE_ECDSA_AES256CBC_SHA :: Cipher -cipher_ECDHE_ECDSA_AES256CBC_SHA = Cipher - { cipherID = 0xC00A - , cipherName = "ECDHE-ECDSA-AES256CBC-SHA" - , cipherBulk = bulk_aes256 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS10 - } - -cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher -cipher_ECDHE_RSA_AES128CBC_SHA = Cipher - { cipherID = 0xC013 - , cipherName = "ECDHE-RSA-AES128CBC-SHA" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherMinVer = Just TLS10 - } - -cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher -cipher_ECDHE_RSA_AES256CBC_SHA = Cipher - { cipherID = 0xC014 - , cipherName = "ECDHE-RSA-AES256CBC-SHA" - , cipherBulk = bulk_aes256 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherMinVer = Just TLS10 - } - -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 - } - -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 - } - -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 - } - -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 - } - -cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128CCM_SHA256 = Cipher - { cipherID = 0xc0ac - , cipherName = "ECDHE-ECDSA-AES128CCM-SHA256" - , cipherBulk = bulk_aes128ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 7251 - } - -cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = Cipher - { cipherID = 0xc0ae - , cipherName = "ECDHE-ECDSA-AES128CCM8-SHA256" - , cipherBulk = bulk_aes128ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 7251 - } - -cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher - { cipherID = 0xC02B - , cipherName = "ECDHE-ECDSA-AES128GCM-SHA256" - , cipherBulk = bulk_aes128gcm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 5289 - } - -cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES256CCM_SHA256 = Cipher - { cipherID = 0xc0ad - , cipherName = "ECDHE-ECDSA-AES256CCM-SHA256" - , cipherBulk = bulk_aes256ccm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 7251 - } - -cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher -cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = Cipher - { cipherID = 0xc0af - , cipherName = "ECDHE-ECDSA-AES256CCM8-SHA256" - , cipherBulk = bulk_aes256ccm8 - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 7251 - } - -cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher -cipher_ECDHE_ECDSA_AES256GCM_SHA384 = Cipher - { cipherID = 0xC02C - , cipherName = "ECDHE-ECDSA-AES256GCM-SHA384" - , cipherBulk = bulk_aes256gcm - , cipherHash = SHA384 - , cipherPRFHash = Just SHA384 - , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA - , cipherMinVer = Just TLS12 -- RFC 5289 - } - -cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher -cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher - { cipherID = 0xC02F - , cipherName = "ECDHE-RSA-AES128GCM-SHA256" - , cipherBulk = bulk_aes128gcm - , cipherHash = SHA256 - , cipherPRFHash = Just SHA256 - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 - } - -cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher -cipher_ECDHE_RSA_AES256GCM_SHA384 = Cipher - { cipherID = 0xC030 - , cipherName = "ECDHE-RSA-AES256GCM-SHA384" - , cipherBulk = bulk_aes256gcm - , cipherHash = SHA384 - , cipherPRFHash = Just SHA384 - , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA - , cipherMinVer = Just TLS12 -- RFC 5289 - } - --- A list of cipher suite is found from: --- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 +module Network.TLS.Extra.Cipher ( + -- * cipher suite + ciphersuite_default, + ciphersuite_default_det, + ciphersuite_all, + ciphersuite_all_det, + ciphersuite_strong, + ciphersuite_strong_det, + + -- * 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 + 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 + +import Data.Tuple (swap) +import Network.TLS.Cipher +import Network.TLS.Types (Version (..)) + +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 + +chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD +chacha20poly1305 BulkEncrypt key nonce = + let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) + in ( \input ad -> + let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) + (output, st3) = ChaChaPoly1305.encrypt input st2 + Poly1305.Auth tag = ChaChaPoly1305.finalize st3 + in (output, AuthTag tag) + ) +chacha20poly1305 BulkDecrypt key nonce = + let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) + in ( \input ad -> + let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st) + (output, st3) = ChaChaPoly1305.decrypt input st2 + Poly1305.Auth tag = ChaChaPoly1305.finalize st3 + in (output, AuthTag tag) + ) + +---------------------------------------------------------------- + +data CipherSet + = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm + | SetOther [Cipher] + +-- Preference between AEAD ciphers having equivalent properties is based on +-- hardware-acceleration support in the crypton implementation. +sortOptimized :: [CipherSet] -> [Cipher] +sortOptimized = concatMap f + where + f (SetAead gcm chacha ccm) + | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm + | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm + | otherwise = gcm ++ ccm ++ chacha + f (SetOther ciphers) = ciphers + +-- Order which is deterministic but not optimized for the CPU. +sortDeterministic :: [CipherSet] -> [Cipher] +sortDeterministic = concatMap f + where + f (SetAead gcm chacha ccm) = gcm ++ chacha ++ ccm + f (SetOther ciphers) = ciphers + +-- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to +-- weak. This choice of ciphersuites should satisfy most normal needs. For +-- otherwise strong ciphers we make little distinction between AES128 and +-- AES256, and list each but the weakest of the AES128 ciphers ahead of the +-- corresponding AES256 ciphers. +-- +-- AEAD ciphers with equivalent security properties are ordered based on CPU +-- hardware-acceleration support. If this dynamic runtime behavior is not +-- desired, use 'ciphersuite_default_det' instead. +ciphersuite_default :: [Cipher] +ciphersuite_default = sortOptimized sets_default + +-- | 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] + ] + +---------------------------------------------------------------- + +-- | The default ciphersuites + some not recommended last resort ciphers. +-- +-- AEAD ciphers with equivalent security properties are ordered based on CPU +-- hardware-acceleration support. If this dynamic runtime behavior is not +-- desired, use 'ciphersuite_all_det' instead. +ciphersuite_all :: [Cipher] +ciphersuite_all = ciphersuite_default ++ complement_all + +-- | Same as 'ciphersuite_all', but using deterministic preference not +-- influenced by the CPU. +ciphersuite_all_det :: [Cipher] +ciphersuite_all_det = ciphersuite_default_det ++ complement_all + +complement_all :: [Cipher] +complement_all = + [ cipher_ECDHE_ECDSA_AES128CCM8_SHA256 + , cipher_ECDHE_ECDSA_AES256CCM8_SHA256 + , cipher_TLS13_AES128CCM8_SHA256 + ] + +-- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we +-- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305 +-- variants. For weaker constructs, we use just the AES256 form. +-- +-- AEAD ciphers with equivalent security properties are ordered based on CPU +-- hardware-acceleration support. If this dynamic runtime behavior is not +-- desired, use 'ciphersuite_strong_det' instead. +ciphersuite_strong :: [Cipher] +ciphersuite_strong = sortOptimized sets_strong + +-- | Same as 'ciphersuite_strong', but using deterministic preference not +-- influenced by the CPU. +ciphersuite_strong_det :: [Cipher] +ciphersuite_strong_det = sortDeterministic sets_strong + +sets_strong :: [CipherSet] +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] + , SetAead + [cipher_ECDHE_ECDSA_AES128GCM_SHA256] + [] + [cipher_ECDHE_ECDSA_AES128CCM_SHA256] + , SetAead + [cipher_ECDHE_RSA_AES256GCM_SHA384] + [cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256] + [] + , SetAead + [cipher_ECDHE_RSA_AES128GCM_SHA256] + [] + [] + , -- TLS13 (listed at the end but version is negotiated first) + SetAead + [cipher_TLS13_AES256GCM_SHA384] + [cipher_TLS13_CHACHA20POLY1305_SHA256] + [] + , SetAead + [cipher_TLS13_AES128GCM_SHA256] + [] + [cipher_TLS13_AES128CCM_SHA256] + ] + +---------------------------------------------------------------- + +bulk_aes128ccm :: Bulk +bulk_aes128ccm = + Bulk + { bulkName = "AES128CCM" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128ccm + } + +bulk_aes128ccm8 :: Bulk +bulk_aes128ccm8 = + Bulk + { bulkName = "AES128CCM8" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 8 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128ccm8 + } + +bulk_aes128gcm :: Bulk +bulk_aes128gcm = + Bulk + { bulkName = "AES128GCM" + , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes128gcm + } + +bulk_aes256ccm :: Bulk +bulk_aes256ccm = + Bulk + { bulkName = "AES256CCM" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256ccm + } + +bulk_aes256ccm8 :: Bulk +bulk_aes256ccm8 = + Bulk + { bulkName = "AES256CCM8" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 6655 CCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 8 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256ccm8 + } + +bulk_aes256gcm :: Bulk +bulk_aes256gcm = + Bulk + { bulkName = "AES256GCM" + , bulkKeySize = 32 -- RFC 5116 Sec 5.1: K_LEN + , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length + , bulkExplicitIV = 8 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF aes256gcm + } + +bulk_chacha20poly1305 :: Bulk +bulk_chacha20poly1305 = + Bulk + { bulkName = "CHACHA20POLY1305" + , bulkKeySize = 32 + , bulkIVSize = 12 -- RFC 7905 section 2, fixed_iv_length + , bulkExplicitIV = 0 + , bulkAuthTagLen = 16 + , bulkBlockSize = 0 -- dummy, not used + , bulkF = BulkAeadF chacha20poly1305 + } + +-- TLS13 bulks are same as TLS12 except they never have explicit IV +bulk_aes128gcm_13 :: Bulk +bulk_aes128gcm_13 = bulk_aes128gcm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes256gcm_13 :: Bulk +bulk_aes256gcm_13 = bulk_aes256gcm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes128ccm_13 :: Bulk +bulk_aes128ccm_13 = bulk_aes128ccm{bulkIVSize = 12, bulkExplicitIV = 0} + +bulk_aes128ccm8_13 :: Bulk +bulk_aes128ccm8_13 = bulk_aes128ccm8{bulkIVSize = 12, bulkExplicitIV = 0} + +---------------------------------------------------------------- + +-- A list of cipher suite is found from: +-- https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-4 + +---------------------------------------------------------------- +-- RFC 8446 + +cipher_TLS13_AES128GCM_SHA256 :: Cipher +cipher_TLS13_AES128GCM_SHA256 = + Cipher + { cipherID = 0x1301 + , cipherName = "TLS_AES_128_GCM_SHA256" + , cipherBulk = bulk_aes128gcm_13 + , cipherHash = SHA256 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13 + } + +cipher_TLS13_AES256GCM_SHA384 :: Cipher +cipher_TLS13_AES256GCM_SHA384 = + Cipher + { cipherID = 0x1302 + , cipherName = "TLS_AES_256_GCM_SHA384" + , cipherBulk = bulk_aes256gcm_13 + , cipherHash = SHA384 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13 + } + +cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher +cipher_TLS13_CHACHA20POLY1305_SHA256 = + Cipher + { cipherID = 0x1303 + , cipherName = "TLS_CHACHA20_POLY1305_SHA256" + , cipherBulk = bulk_chacha20poly1305 + , cipherHash = SHA256 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13 + } + +cipher_TLS13_AES128CCM_SHA256 :: Cipher +cipher_TLS13_AES128CCM_SHA256 = + Cipher + { cipherID = 0x1304 + , cipherName = "TLS_AES_128_CCM_SHA256" + , cipherBulk = bulk_aes128ccm_13 + , cipherHash = SHA256 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13 + } + +cipher_TLS13_AES128CCM8_SHA256 :: Cipher +cipher_TLS13_AES128CCM8_SHA256 = + Cipher + { cipherID = 0x1305 + , cipherName = "TLS_AES_128_CCM_8_SHA256" + , cipherBulk = bulk_aes128ccm8_13 + , cipherHash = SHA256 + , cipherPRFHash = Nothing + , cipherKeyExchange = CipherKeyExchange_TLS13 + , cipherMinVer = Just TLS13 + } + +---------------------------------------------------------------- +-- GCM: RFC 5289 + +cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128GCM_SHA256 = + Cipher + { cipherID = 0xC02B + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256" + , cipherBulk = bulk_aes128gcm + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher +cipher_ECDHE_ECDSA_AES256GCM_SHA384 = + Cipher + { cipherID = 0xC02C + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384" + , cipherBulk = bulk_aes256gcm + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher +cipher_ECDHE_RSA_AES128GCM_SHA256 = + Cipher + { cipherID = 0xC02F + , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256" + , cipherBulk = bulk_aes128gcm + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 + } + +cipher_ECDHE_RSA_AES256GCM_SHA384 :: Cipher +cipher_ECDHE_RSA_AES256GCM_SHA384 = + Cipher + { cipherID = 0xC030 + , cipherName = "TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384" + , cipherBulk = bulk_aes256gcm + , cipherHash = SHA384 + , cipherPRFHash = Just SHA384 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 -- RFC 5289 + } + +---------------------------------------------------------------- +-- CCM/ECC: RFC 7251 + +cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CCM_SHA256 = + Cipher + { cipherID = 0xC0AC + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM" + , cipherBulk = bulk_aes128ccm + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 7251 + } + +cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES256CCM_SHA256 = + Cipher + { cipherID = 0xC0AD + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM" + , cipherBulk = bulk_aes256ccm + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 7251 + } + +cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = + Cipher + { cipherID = 0xC0AE + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_128_CCM_8" + , cipherBulk = bulk_aes128ccm8 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 7251 + } + +cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher +cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = + Cipher + { cipherID = 0xC0AF + , cipherName = "TLS_ECDHE_ECDSA_WITH_AES_256_CCM_8" + , cipherBulk = bulk_aes256ccm8 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 -- RFC 7251 + } + +---------------------------------------------------------------- +-- RFC 7905 + +cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher +cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = + Cipher + { cipherID = 0xCCA8 + , cipherName = "TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256" + , cipherBulk = bulk_chacha20poly1305 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA + , cipherMinVer = Just TLS12 + } + +cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher +cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = + Cipher + { cipherID = 0xCCA9 + , cipherName = "TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256" + , cipherBulk = bulk_chacha20poly1305 + , cipherHash = SHA256 + , cipherPRFHash = Just SHA256 + , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA + , cipherMinVer = Just TLS12 + } diff --git a/Network/TLS/Extra/FFDHE.hs b/Network/TLS/Extra/FFDHE.hs --- a/Network/TLS/Extra/FFDHE.hs +++ b/Network/TLS/Extra/FFDHE.hs @@ -15,48 +15,58 @@ -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 103 bits. ffdhe2048 :: DHParams -ffdhe2048 = Params { - params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF - , params_g = 2 - , params_bits = 2048 - } +ffdhe2048 = + Params + { params_p = + 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF + , params_g = 2 + , params_bits = 2048 + } -- | 3072 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 125 bits. ffdhe3072 :: DHParams -ffdhe3072 = Params { - params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF - , params_g = 2 - , params_bits = 3072 - } +ffdhe3072 = + Params + { params_p = + 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF + , params_g = 2 + , params_bits = 3072 + } -- | 4096 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 150 bits. ffdhe4096 :: DHParams -ffdhe4096 = Params { - params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF - , params_g = 2 - , params_bits = 4096 - } +ffdhe4096 = + Params + { params_p = + 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF + , params_g = 2 + , params_bits = 4096 + } -- | 6144 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 175 bits. ffdhe6144 :: DHParams -ffdhe6144 = Params { - params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF - , params_g = 2 - , params_bits = 6144 - } +ffdhe6144 = + Params + { params_p = + 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF + , params_g = 2 + , params_bits = 6144 + } -- | 8192 bits finite field Diffie-Hellman ephemeral parameters -- defined in RFC 7919. -- The estimated symmetric-equivalent strength is 192 bits. ffdhe8192 :: DHParams -ffdhe8192 = Params { - params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF - , params_g = 2 - , params_bits = 8192 - } +ffdhe8192 = + Params + { params_p = + 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF + , params_g = 2 + , params_bits = 8192 + } diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -1,33 +1,26 @@ --- | --- Module : Network.TLS.Handshake --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake - ( handshake - , handshakeWith - , handshakeClientWith - , handshakeServerWith - , handshakeClient - , handshakeServer - ) where +module Network.TLS.Handshake ( + handshake_, + handshakeWith, + handshakeClientWith, + handshakeServerWith, + handshakeClient, + handshakeServer, +) where import Network.TLS.Context.Internal import Network.TLS.Struct -import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client +import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server import Control.Monad.State.Strict --- | Handshake for a new TLS connection --- This is to be called at the beginning of a connection, and during renegotiation -handshake :: MonadIO m => Context -> m () -handshake ctx = - liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) +handshake_ :: MonadIO m => Context -> m () +handshake_ ctx = + liftIO $ + withRWLock ctx $ + handleException ctx (doHandshake_ (ctxRoleParams ctx) ctx) -- Handshake when requested by the remote end -- This is called automatically by 'recvData', in a context where the read lock @@ -35,4 +28,7 @@ -- call withWriteLock. handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs = - liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoHandshakeWith ctx ctx hs + liftIO $ + withWriteLock ctx $ + handleException ctx $ + doHandshakeWith_ (ctxRoleParams ctx) ctx hs diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -1,25 +1,18 @@ --- | --- Module : Network.TLS.Handshake.Certificate --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.Certificate - ( certificateRejected - , badCertificate - , rejectOnException - , verifyLeafKeyUsage - , extractCAname - ) where +module Network.TLS.Handshake.Certificate ( + certificateRejected, + badCertificate, + rejectOnException, + verifyLeafKeyUsage, + extractCAname, +) where +import Control.Exception (SomeException) +import Control.Monad (unless) +import Control.Monad.State.Strict +import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet) import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.X509 -import Control.Monad (unless) -import Control.Monad.State.Strict -import Control.Exception (SomeException) -import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a @@ -41,16 +34,17 @@ rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m () -verifyLeafKeyUsage _ (CertificateChain []) = return () -verifyLeafKeyUsage validFlags (CertificateChain (signed:_)) = - unless verified $ badCertificate $ - "certificate is not allowed for any of " ++ show validFlags +verifyLeafKeyUsage _ (CertificateChain []) = return () +verifyLeafKeyUsage validFlags (CertificateChain (signed : _)) = + unless verified $ + badCertificate $ + "certificate is not allowed for any of " ++ show validFlags where - cert = getCertificate signed + cert = getCertificate signed verified = case extensionGet (certExtensions cert) of - Nothing -> True -- unrestricted cert - Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags + Nothing -> True -- unrestricted cert + Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -1,1072 +1,152 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Client --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.Client - ( handshakeClient - , handshakeClientWith - , postHandshakeAuthClientWith - ) where - -import Network.TLS.Crypto -import Network.TLS.Context.Internal -import Network.TLS.Parameters -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.Cipher -import Network.TLS.Compression -import Network.TLS.Credentials -import Network.TLS.Packet hiding (getExtensions) -import Network.TLS.ErrT -import Network.TLS.Extension -import Network.TLS.IO -import Network.TLS.Imports -import Network.TLS.State -import Network.TLS.Measurement -import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) -import Network.TLS.Types -import Network.TLS.X509 -import qualified Data.ByteString as B -import Data.X509 (ExtKeyUsageFlag(..)) - -import Control.Monad.State.Strict -import Control.Exception (SomeException, bracket) - -import Network.TLS.Handshake.Certificate -import Network.TLS.Handshake.Common -import Network.TLS.Handshake.Common13 -import Network.TLS.Handshake.Control -import Network.TLS.Handshake.Key -import Network.TLS.Handshake.Process -import Network.TLS.Handshake.Random -import Network.TLS.Handshake.Signature -import Network.TLS.Handshake.State -import Network.TLS.Handshake.State13 -import Network.TLS.Wire - -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () -handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx -handshakeClientWith _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in handshakeClientWith" HandshakeFailure - --- 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 = do - let 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 - groupsSupported = supportedGroups (ctxSupported ctx) - handshakeClient' cparams ctx groups Nothing - --- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: --- "The client will also send a --- ClientHello when the server has responded to its ClientHello with a --- HelloRetryRequest. In that case, the client MUST send the same --- ClientHello without modification, except as follows:" --- --- So, the ClientRandom in the first client hello is necessary. -handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO () -handshakeClient' cparams ctx groups mparams = do - updateMeasure ctx incrementNbHandshakes - (crand, clientSession) <- generateClientHelloParams - (rtt0, sentExtensions) <- sendClientHello clientSession crand - recvServerHello clientSession sentExtensions - ver <- usingState_ ctx getVersion - unless (maybe True (\(_, _, v) -> v == ver) mparams) $ - throwCore $ Error_Protocol "version changed after hello retry" IllegalParameter - -- recvServerHello sets TLS13HRR according to the server random. - -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise. - -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR. - hrr <- usingState_ ctx getTLS13HRR - if ver == TLS13 then - if hrr then case drop 1 groups of - [] -> throwCore $ Error_Protocol "group is exhausted in the client side" IllegalParameter - groups' -> do - 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 - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - clearTxState ctx - let cparams' = cparams { clientEarlyData = Nothing } - runPacketFlight ctx $ sendChangeCipherSpec13 ctx - handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) - | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter - Just _ -> error "handshakeClient': invalid KeyShare value" - Nothing -> throwCore $ Error_Protocol "key exchange not implemented in HRR, expected key_share extension" HandshakeFailure - else - handshakeClient13 cparams ctx groupToSend - else do - when rtt0 $ - throwCore $ Error_Protocol "server denied TLS 1.3 when connecting with early data" HandshakeFailure - sessionResuming <- usingState_ ctx isSessionResuming - if sessionResuming - then sendChangeCipherAndFinish ctx ClientRole - else do sendClientData cparams ctx - sendChangeCipherAndFinish ctx ClientRole - recvChangeCipherAndFinish ctx - handshakeTerminate ctx - where ciphers = supportedCiphers $ ctxSupported ctx - compressions = supportedCompressions $ ctxSupported ctx - highestVer = maximum $ supportedVersions $ ctxSupported ctx - tls13 = highestVer >= TLS13 - ems = supportedExtendedMasterSec $ 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 - -- are allergic to an extension with empty data at final position. - -- - -- Without TLS 1.3, the list ends with extension "signature_algorithms" - -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions - -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key" - -- (not always present) have length > 0. - getExtensions pskInfo rtt0 = sequence - [ sniExtension - , secureReneg - , alpnExtension - , emsExtension - , groupExtension - , ecPointExtension - --, sessionTicketExtension - , signatureAlgExtension - --, heartbeatExtension - , versionExtension - , earlyDataExtension rtt0 - , keyshareExtension - , cookieExtension - , postHandshakeAuthExtension - , pskExchangeModeExtension - , preSharedKeyExtension pskInfo -- MUST be last (RFC 8446) - ] - - toExtensionRaw :: Extension e => e -> ExtensionRaw - toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) - - secureReneg = - if supportedSecureRenegotiation $ ctxSupported ctx - then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing - 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 ExtendedMasterSecret - sniExtension = if clientUseServerNameIndication cparams - then do let sni = fst $ clientServerIdentification cparams - usingState_ ctx $ setClientSNI sni - return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] - else return Nothing - - groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) - ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] - --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] - --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend - --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket - - signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams - - versionExtension - | tls13 = do - let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx - return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers - | otherwise = return Nothing - - -- FIXME - keyshareExtension - | tls13 = case groupToSend of - Nothing -> return Nothing - Just grp -> do - (cpri, ent) <- makeClientKeyShare ctx grp - usingHState ctx $ setGroupPrivate cpri - return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] - | otherwise = return Nothing - - sessionAndCipherToResume13 = do - guard tls13 - (sid, sdata) <- clientWantSessionResume cparams - guard (sessionVersion sdata >= TLS13) - sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers - return (sid, sdata, sCipher) - - getPskInfo = - case sessionAndCipherToResume13 of - Nothing -> return Nothing - Just (sid, sdata, sCipher) -> do - let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata - age <- getAge tinfo - return $ if isAgeValid age tinfo - then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo) - else Nothing - - preSharedKeyExtension pskInfo = - case pskInfo of - Nothing -> return Nothing - Just (sid, _, choice, obfAge) -> - let zero = cZero choice - identity = PskIdentity sid obfAge - offeredPsks = PreSharedKeyClientHello [identity] [zero] - in return $ Just $ toExtensionRaw offeredPsks - - pskExchangeModeExtension - | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] - | otherwise = return Nothing - - earlyDataExtension rtt0 - | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) - | otherwise = return Nothing - - cookieExtension = do - mcookie <- usingState_ ctx getTLS13Cookie - case mcookie of - Nothing -> return Nothing - Just cookie -> return $ Just $ toExtensionRaw cookie - - postHandshakeAuthExtension - | ctxQUICMode ctx = return Nothing - | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth - | otherwise = return Nothing - - adjustExtentions pskInfo exts ch = - case pskInfo of - Nothing -> return exts - Just (_, sdata, choice, _) -> do - let psk = sessionSecret sdata - earlySecret = initEarlySecret choice (Just psk) - usingHState ctx $ setTLS13EarlySecret earlySecret - let ech = encodeHandshake ch - h = cHash choice - siz = hashDigestSize h - binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) - let exts' = init exts ++ [adjust (last exts)] - adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders - where - withBinders = replacePSKBinder withoutBinders binder - return exts' - - generateClientHelloParams = - case mparams of - -- Client random and session in the second client hello for - -- retry must be the same as the first one. - Just (crand, clientSession, _) -> return (crand, clientSession) - Nothing -> do - crand <- clientRandom ctx - let paramSession = case clientWantSessionResume cparams of - Nothing -> Session Nothing - Just (sid, sdata) - | sessionVersion sdata >= TLS13 -> Session Nothing - | ems == RequireEMS && noSessionEMS -> Session Nothing - | otherwise -> Session (Just sid) - where noSessionEMS = SessionEMS `notElem` sessionFlags sdata - -- In compatibility mode a client not offering a pre-TLS 1.3 - -- session MUST generate a new 32-byte value - if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx) - then do - randomSession <- newSession ctx - return (crand, randomSession) - else return (crand, paramSession) - - sendClientHello clientSession crand = do - let ver = if tls13 then TLS12 else highestVer - hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx ver crand - usingState_ ctx $ setVersionIfUnset highestVer - let cipherIds = map cipherID ciphers - compIds = map compressionID compressions - mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing - pskInfo <- getPskInfo - let rtt0info = pskInfo >>= get0RTTinfo - rtt0 = isJust rtt0info - extensions0 <- catMaybes <$> getExtensions pskInfo rtt0 - let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0 - extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1 - sendPacket ctx $ Handshake [mkClientHello extensions] - mEarlySecInfo <- case rtt0info of - Nothing -> return Nothing - Just info -> Just <$> send0RTT info - unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo - return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) - - get0RTTinfo (_, sdata, choice, _) = do - earlyData <- clientEarlyData cparams - guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) - return (choice, earlyData) - - send0RTT (choice, earlyData) = 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 - let clientEarlySecret = pairClient earlyKey - unless (ctxQUICMode ctx) $ do - runPacketFlight ctx $ sendChangeCipherSpec13 ctx - setTxState ctx usedHash usedCipher clientEarlySecret - let len = ctxFragmentSize ctx - mapChunks_ len (sendPacket13 ctx . AppData13) earlyData - -- We set RTT0Sent even in quicMode - usingHState ctx $ setTLS13RTT0Status RTT0Sent - return $ EarlySecretInfo usedCipher clientEarlySecret - - recvServerHello clientSession sentExts = runRecvState ctx recvState - where recvState = RecvStateNext $ \p -> - case p of - Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages - Alert a -> - case a of - [(AlertLevel_Warning, UnrecognizedName)] -> - if clientUseServerNameIndication cparams - then return recvState - else throwAlert a - _ -> throwAlert a - _ -> unexpected (show p) (Just "handshake") - throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a) HandshakeFailure - --- | Store the keypair and check that it is compatible with the current protocol --- version and a list of 'CertificateType' values. -storePrivInfoClient :: Context - -> [CertificateType] - -> Credential - -> IO () -storePrivInfoClient ctx cTypes (cc, privkey) = do - pubkey <- storePrivInfo ctx cc privkey - unless (certificateCompatible pubkey cTypes) $ - throwCore $ Error_Protocol (pubkeyType pubkey ++ " credential does not match allowed certificate types") InternalError - ver <- usingState_ ctx getVersion - unless (pubkey `versionCompatible` ver) $ - throwCore $ Error_Protocol (pubkeyType pubkey ++ " credential is not supported at version " ++ show ver) InternalError - --- | When the server requests a client certificate, we try to --- obtain a suitable certificate chain and private key via the --- callback in the client parameters. It is OK for the callback --- to return an empty chain, in many cases the client certificate --- is optional. If the client wishes to abort the handshake for --- lack of a suitable certificate, it can throw an exception in --- the callback. --- --- The return value is 'Nothing' when no @CertificateRequest@ was --- received and no @Certificate@ message needs to be sent. An empty --- chain means that an empty @Certificate@ message needs to be sent --- to the server, naturally without a @CertificateVerify@. A non-empty --- 'CertificateChain' is the chain to send to the server along with --- a corresponding 'CertificateVerify'. --- --- With TLS < 1.2 the server's @CertificateRequest@ does not carry --- a signature algorithm list. It has a list of supported public --- key signing algorithms in the @certificate_types@ field. The --- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA. --- --- With TLS == 1.2 the server's @CertificateRequest@ always has a --- @supported_signature_algorithms@ list, as a fixed component of --- the structure. This list is (wrongly) overloaded to also limit --- X.509 signatures in the client's certificate chain. The BCP --- strategy is to find a compatible chain if possible, but else --- ignore the constraint, and let the server verify the chain as it --- sees fit. The @supported_signature_algorithms@ field is only --- obligatory with respect to signatures on TLS messages, in this --- case the @CertificateVerify@ message. The @certificate_types@ --- field is still included. --- --- With TLS 1.3 the server's @CertificateRequest@ has a mandatory --- @signature_algorithms@ extension, the @signature_algorithms_cert@ --- extension, which is optional, carries a list of algorithms the --- server promises to support in verifying the certificate chain. --- As with TLS 1.2, the client's makes a /best-effort/ to deliver --- a compatible certificate chain where all the CA signatures are --- known to be supported, but it should not abort the connection --- just because the chain might not work out, just send the best --- chain you have and let the server worry about the rest. The --- supported public key algorithms are now inferred from the --- @signature_algorithms@ extension and @certificate_types@ is --- gone. --- --- With TLS 1.3, we synthesize and store a @certificate_types@ --- field at the time that the server's @CertificateRequest@ --- message is received. This is then present across all the --- protocol versions, and can be used to determine whether --- a @CertificateRequest@ was received or not. --- --- If @signature_algorithms@ is 'Nothing', then we're doing --- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension --- is optional in TLS 1.3, and so the application callback --- will not be able to distinguish between TLS 1.[01] and --- TLS 1.3 with no certificate algorithm hints, but this --- just simplifies the chain selection process, all CA --- signatures are OK. --- -clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain) -clientChain cparams ctx = - usingHState ctx getCertReqCBdata >>= \case - Nothing -> return Nothing - Just cbdata -> do - let callback = onCertificateRequest $ clientHooks cparams - chain <- liftIO $ callback cbdata `catchException` - throwMiscErrorOnException "certificate request callback failed" - case chain of - Nothing - -> return $ Just $ CertificateChain [] - Just (CertificateChain [], _) - -> return $ Just $ CertificateChain [] - Just cred@(cc, _) - -> do - let (cTypes, _, _) = cbdata - storePrivInfoClient ctx cTypes cred - return $ Just cc - --- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with --- the local key and server's signature algorithms (both already saved). Must --- only be called for TLS versions 1.2 and up, with compatibility function --- 'signatureCompatible' or 'signatureCompatible13' based on version. --- --- The values in the server's @signature_algorithms@ extension are --- in descending order of preference. However here the algorithms --- are selected by client preference in @cHashSigs@. --- -getLocalHashSigAlg :: Context - -> (PubKey -> HashAndSignatureAlgorithm -> Bool) - -> [HashAndSignatureAlgorithm] - -> PubKey - -> IO HashAndSignatureAlgorithm -getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do - -- Must be present with TLS 1.2 and up. - (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata - let want = (&&) <$> isCompatible pubKey - <*> flip elem hashSigs - case find want cHashSigs of - Just best -> return best - Nothing -> throwCore $ Error_Protocol (keyerr pubKey) HandshakeFailure - where - keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" - --- | Return the supported 'CertificateType' values that are --- compatible with at least one supported signature algorithm. --- -supportedCtypes :: [HashAndSignatureAlgorithm] - -> [CertificateType] -supportedCtypes hashAlgs = - nub $ foldr ctfilter [] hashAlgs - where - ctfilter x acc = case hashSigToCertType x of - Just cType | cType <= lastSupportedCertificateType - -> cType : acc - _ -> acc --- -clientSupportedCtypes :: Context - -> [CertificateType] -clientSupportedCtypes ctx = - supportedCtypes $ supportedHashSignatures $ ctxSupported ctx --- -sigAlgsToCertTypes :: Context - -> [HashAndSignatureAlgorithm] - -> [CertificateType] -sigAlgsToCertTypes ctx hashSigs = - filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx - --- | TLS 1.2 and below. Send the client handshake messages that --- follow the @ServerHello@, etc. except for @CCS@ and @Finished@. --- --- XXX: Is any buffering done here to combined these messages into --- a single TCP packet? Otherwise we're prone to Nagle delays, or --- in any case needlessly generate multiple small packets, where --- a single larger packet will do. The TLS 1.3 code path seems --- to separating record generation and transmission and sending --- multiple records in a single packet. --- --- -> [certificate] --- -> client key exchange --- -> [cert verify] -sendClientData :: ClientParams -> Context -> IO () -sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify - where - sendCertificate = do - usingHState ctx $ setClientCertSent False - clientChain cparams ctx >>= \case - Nothing -> return () - Just cc@(CertificateChain certs) -> do - unless (null certs) $ - usingHState ctx $ setClientCertSent True - sendPacket ctx $ Handshake [Certificates cc] - - sendClientKeyXchg = do - cipher <- usingHState ctx getPendingCipher - (ckx, setMasterSec) <- case cipherKeyExchange cipher of - CipherKeyExchange_RSA -> do - clientVersion <- usingHState ctx $ gets hstClientVersion - (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 - - let premaster = encodePreMasterSecret clientVersion prerand - setMasterSec = setMasterSecretFromPre xver ClientRole premaster - encryptedPreMaster <- do - -- SSL3 implementation generally forget this length field since it's redundant, - -- however TLS10 make it clear that the length field need to be present. - e <- encryptRSA ctx premaster - let extra = if xver < TLS10 - then B.empty - else encodeWord16 $ fromIntegral $ B.length e - return $ extra `B.append` e - return (CKX_RSA encryptedPreMaster, setMasterSec) - CipherKeyExchange_DHE_RSA -> getCKX_DHE - CipherKeyExchange_DHE_DSS -> getCKX_DHE - CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE - CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE - _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure - sendPacket ctx $ Handshake [ClientKeyXchg ckx] - masterSecret <- usingHState ctx setMasterSec - logKey ctx (MasterSecret masterSecret) - where getCKX_DHE = do - xver <- usingState_ ctx getVersion - serverParams <- usingHState ctx getServerDHParams - - let params = serverDHParamsToParams serverParams - ffGroup = findFiniteFieldGroup params - srvpub = serverDHParamsToPublic serverParams - - unless (maybe False (isSupportedGroup ctx) ffGroup) $ do - groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException` - throwMiscErrorOnException "custom group callback failed" - case groupUsage of - GroupUsageInsecure -> throwCore $ Error_Protocol "FFDHE group is not secure enough" InsufficientSecurity - GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason) HandshakeFailure - GroupUsageInvalidPublic -> throwCore $ Error_Protocol "invalid server public key" IllegalParameter - GroupUsageValid -> return () - - -- When grp is known but not in the supported list we use it - -- anyway. This provides additional validation and a more - -- efficient implementation. - (clientDHPub, premaster) <- - case ffGroup of - Nothing -> do - (clientDHPriv, clientDHPub) <- generateDHE ctx params - let premaster = dhGetShared params clientDHPriv srvpub - return (clientDHPub, premaster) - Just grp -> do - usingHState ctx $ setNegotiatedGroup grp - dhePair <- generateFFDHEShared ctx grp srvpub - case dhePair of - Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter - Just pair -> return pair - - let setMasterSec = setMasterSecretFromPre xver ClientRole premaster - return (CKX_DH clientDHPub, setMasterSec) - - getCKX_ECDHE = do - ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams - checkSupportedGroup ctx grp - usingHState ctx $ setNegotiatedGroup grp - ecdhePair <- generateECDHEShared ctx srvpub - case ecdhePair of - Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter - Just (clipub, premaster) -> do - xver <- usingState_ ctx getVersion - let setMasterSec = setMasterSecretFromPre xver ClientRole premaster - return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec) - - -- In order to send a proper certificate verify message, - -- we have to do the following: - -- - -- 1. Determine which signing algorithm(s) the server supports - -- (we currently only support RSA). - -- 2. Get the current handshake hash from the handshake state. - -- 3. Sign the handshake hash - -- 4. Send it to the server. - -- - sendCertificateVerify = do - ver <- usingState_ ctx getVersion - - -- Only send a certificate verify message when we - -- have sent a non-empty list of certificates. - -- - certSent <- usingHState ctx getClientCertSent - when certSent $ do - pubKey <- getLocalPublicKey ctx - mhashSig <- case ver of - TLS12 -> - let cHashSigs = supportedHashSignatures $ ctxSupported ctx - in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey - _ -> return Nothing - - -- Fetch all handshake messages up to now. - msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs - sendPacket ctx $ Handshake [CertVerify sigDig] - -processServerExtension :: ExtensionRaw -> TLSSt () -processServerExtension (ExtensionRaw extID content) - | extID == extensionID_SecureRenegotiation = do - cv <- getVerifiedData ClientRole - sv <- getVerifiedData ServerRole - let bs = extensionEncode (SecureRenegotiation cv $ Just sv) - unless (bs `bytesEq` content) $ throwError $ Error_Protocol "server secure renegotiation data not matching" HandshakeFailure - | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of - Just (SupportedVersionsServerHello ver) -> setVersion ver - _ -> return () - | extID == extensionID_KeyShare = do - hrr <- getTLS13HRR - let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello - setTLS13KeyShare $ extensionDecode msgt content - | extID == extensionID_PreSharedKey = - setTLS13PreSharedKey $ extensionDecode MsgTServerHello content -processServerExtension _ = return () - -throwMiscErrorOnException :: String -> SomeException -> IO a -throwMiscErrorOnException msg e = - throwCore $ Error_Misc $ msg ++ ": " ++ show e - --- | onServerHello process 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 --- 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 --- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher --- -onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO) -onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do - when (rver == SSL2) $ throwCore $ Error_Protocol "SSL2 is not supported" ProtocolVersion - when (rver == SSL3) $ throwCore $ Error_Protocol "SSL3 is not supported" ProtocolVersion - -- find the compression and cipher methods that the server want to use. - cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of - Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter - Just alg -> return alg - compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of - Nothing -> throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter - Just alg -> return alg - - -- 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 == extensionID_Cookie = False -- for HRR - | otherwise = i `notElem` sentExts - when (any checkExt exts) $ - throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension - - let resumingSession = - case clientWantSessionResume cparams of - Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing - Nothing -> Nothing - isHRR = isHelloRetryRequest serverRan - usingState_ ctx $ do - setTLS13HRR isHRR - setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello) - setSession serverSession (isJust resumingSession) - setVersion rver -- must be before processing supportedVersions ext - mapM_ processServerExtension exts - - setALPN ctx MsgTServerHello exts - - ver <- usingState_ ctx getVersion - - -- 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 (supportedVersions $ clientSupported cparams) serverRan) $ - throwCore $ Error_Protocol "version downgrade detected" IllegalParameter - - case find (== ver) (supportedVersions $ ctxSupported ctx) of - Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported") ProtocolVersion - Just _ -> return () - if ver > TLS12 then do - when (serverSession /= clientSession) $ - throwCore $ Error_Protocol "received mismatched legacy session" IllegalParameter - established <- ctxEstablished ctx - eof <- ctxEOF ctx - when (established == Established && not eof) $ - throwCore $ Error_Protocol "renegotiation to TLS 1.3 or later is not allowed" ProtocolVersion - ensureNullCompression compression - failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg - return RecvStateDone - else do - ems <- processExtendedMasterSec ctx ver MsgTServerHello exts - usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - case resumingSession of - Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) - Just sessionData -> do - let emsSession = SessionEMS `elem` sessionFlags sessionData - when (ems /= emsSession) $ - let err = "server resumes a session which is not EMS consistent" - in throwCore $ Error_Protocol err HandshakeFailure - let masterSecret = sessionSecret sessionData - usingHState ctx $ setMasterSecret rver ClientRole masterSecret - logKey ctx (MasterSecret masterSecret) - return $ RecvStateNext expectChangeCipher -onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello") - -processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) -processCertificate cparams ctx (Certificates certs) = do - when (isNullCertificateChain certs) $ - throwCore $ Error_Protocol "server certificate missing" DecodeError - -- run certificate recv hook - ctxWithHooks ctx (`hookRecvCertificates` certs) - -- then run certificate validation - usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException - case usage of - CertificateUsageAccept -> checkLeafCertificateKeyUsage - CertificateUsageReject reason -> certificateRejected reason - return $ RecvStateHandshake (processServerKeyExchange ctx) - where shared = clientShared cparams - checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared) - (sharedValidationCache shared) - (clientServerIdentification cparams) - certs - -- also verify that the certificate optional key usage is compatible - -- with the intended key-exchange. This check is not delegated to - -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated - -- cipher, which is not available from onServerCertificate parameters. - -- Additionally, with only one shared ValidationCache, x509-validation - -- would cache validation result based on a key usage and reuse it with - -- another key usage. - checkLeafCertificateKeyUsage = do - cipher <- usingHState ctx getPendingCipher - case requiredCertKeyUsage cipher of - [] -> return () - flags -> verifyLeafKeyUsage flags certs - -processCertificate _ ctx p = processServerKeyExchange ctx p - -expectChangeCipher :: Packet -> IO (RecvState IO) -expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish -expectChangeCipher p = unexpected (show p) (Just "change cipher") - -expectFinish :: Handshake -> IO (RecvState IO) -expectFinish (Finished _) = return RecvStateDone -expectFinish p = unexpected (show p) (Just "Handshake Finished") - -processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) -processServerKeyExchange ctx (ServerKeyXchg origSkx) = do - cipher <- usingHState ctx getPendingCipher - processWithCipher cipher origSkx - return $ RecvStateHandshake (processCertificateRequest ctx) - where processWithCipher cipher skx = - case (cipherKeyExchange cipher, skx) of - (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> - doDHESignature dhparams signature KX_RSA - (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> - doDHESignature dhparams signature KX_DSS - (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> - doECDHESignature ecdhparams signature KX_RSA - (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> - doECDHESignature ecdhparams signature KX_ECDSA - (cke, SKX_Unparsed bytes) -> do - ver <- usingState_ ctx getVersion - case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of - Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke) HandshakeFailure - Right realSkx -> processWithCipher cipher realSkx - -- we need to resolve the result. and recall processWithCipher .. - (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c) HandshakeFailure - doDHESignature dhparams signature kxsAlg = do - -- FF group selected by the server is verified when generating CKX - publicKey <- getSignaturePublicKey kxsAlg - verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature - unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) - usingHState ctx $ setServerDHParams dhparams - - doECDHESignature ecdhparams signature kxsAlg = do - -- EC group selected by the server is verified when generating CKX - publicKey <- getSignaturePublicKey kxsAlg - verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature - unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") - usingHState ctx $ setServerECDHParams ecdhparams - - getSignaturePublicKey kxsAlg = do - publicKey <- usingHState ctx getRemotePublicKey - unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ - throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg) HandshakeFailure - ver <- usingState_ ctx getVersion - unless (publicKey `versionCompatible` ver) $ - throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey) IllegalParameter - let groups = supportedGroups (ctxSupported ctx) - unless (satisfiesEcPredicate (`elem` groups) publicKey) $ - throwCore $ Error_Protocol "server public key has unsupported elliptic curve" IllegalParameter - return publicKey - -processServerKeyExchange ctx p = processCertificateRequest ctx p - -processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) -processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do - ver <- usingState_ ctx getVersion - when (ver == TLS12 && isNothing sigAlgs) $ - throwCore $ Error_Protocol "missing TLS 1.2 certificate request signature algorithms" InternalError - let cTypes = filter (<= lastSupportedCertificateType) cTypesSent - usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) - return $ RecvStateHandshake (processServerHelloDone ctx) -processCertificateRequest ctx p = do - usingHState ctx $ setCertReqCBdata Nothing - processServerHelloDone ctx p - -processServerHelloDone :: Context -> Handshake -> IO (RecvState m) -processServerHelloDone _ ServerHelloDone = return RecvStateDone -processServerHelloDone _ p = unexpected (show p) (Just "server hello data") - --- Unless result is empty, server certificate must be allowed for at least one --- of the returned values. Constraints for RSA-based key exchange are relaxed --- to avoid rejecting certificates having incomplete extension. -requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag] -requiredCertKeyUsage cipher = - case cipherKeyExchange cipher of - CipherKeyExchange_RSA -> rsaCompatibility - CipherKeyExchange_DH_Anon -> [] -- unrestricted - CipherKeyExchange_DHE_RSA -> rsaCompatibility - CipherKeyExchange_ECDHE_RSA -> rsaCompatibility - CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ] - CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ] - CipherKeyExchange_DH_RSA -> rsaCompatibility - CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ] - CipherKeyExchange_ECDH_RSA -> rsaCompatibility - CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ] - CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ] - where rsaCompatibility = [ KeyUsage_digitalSignature - , KeyUsage_keyEncipherment - , KeyUsage_keyAgreement - ] - -handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO () -handshakeClient13 cparams ctx groupSent = do - choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher - handshakeClient13' cparams ctx groupSent choice - -handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO () -handshakeClient13' cparams ctx groupSent choice = do - (_, hkey, resuming) <- switchToHandshakeSecret - let handshakeSecret = triBase hkey - clientHandshakeSecret = triClient hkey - serverHandshakeSecret = triServer hkey - handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret) - contextSync ctx $ RecvServerHello handSecInfo - (rtt0accepted,eexts) <- runRecvHandshake13 $ do - accext <- recvHandshake13 ctx expectEncryptedExtensions - unless resuming $ recvHandshake13 ctx expectCertRequest - recvHandshake13hash ctx $ expectFinished serverHandshakeSecret - return accext - hChSf <- transcriptHash ctx - unless (ctxQUICMode ctx) $ - runPacketFlight ctx $ sendChangeCipherSpec13 ctx - when (rtt0accepted && not (ctxQUICMode ctx)) $ - sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) - setTxState ctx usedHash usedCipher clientHandshakeSecret - sendClientFlight13 cparams ctx usedHash clientHandshakeSecret - appKey <- switchToApplicationSecret handshakeSecret hChSf - let applicationSecret = triBase appKey - setResumptionSecret applicationSecret - let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) - contextSync ctx $ SendClientFinished eexts appSecInfo - handshakeTerminate13 ctx - where - usedCipher = cCipher choice - usedHash = cHash choice - - hashSize = hashDigestSize usedHash - - switchToHandshakeSecret = do - ensureRecvComplete ctx - ecdhe <- calcSharedKey - (earlySecret, resuming) <- makeEarlySecret - handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe - let serverHandshakeSecret = triServer handKey - setRxState ctx usedHash usedCipher serverHandshakeSecret - return (usedCipher, handKey, resuming) - - switchToApplicationSecret handshakeSecret hChSf = do - ensureRecvComplete ctx - appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf - let serverApplicationSecret0 = triServer appKey - let clientApplicationSecret0 = triClient appKey - setTxState ctx usedHash usedCipher clientApplicationSecret0 - setRxState ctx usedHash usedCipher serverApplicationSecret0 - return appKey - - calcSharedKey = do - serverKeyShare <- do - mks <- usingState_ ctx getTLS13KeyShare - case mks of - Just (KeyShareServerHello ks) -> return ks - Just _ -> throwCore $ Error_Protocol "invalid key_share value" IllegalParameter - Nothing -> throwCore $ Error_Protocol "key exchange not implemented, expected key_share extension" HandshakeFailure - let grp = keyShareEntryGroup serverKeyShare - unless (checkKeyShareKeyLength serverKeyShare) $ - throwCore $ Error_Protocol "broken key_share" IllegalParameter - unless (groupSent == Just grp) $ - throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter - usingHState ctx $ setNegotiatedGroup grp - usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare - - makeEarlySecret = do - mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret - case mEarlySecretPSK of - Nothing -> return (initEarlySecret choice Nothing, False) - Just earlySecretPSK@(BaseSecret sec) -> do - mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey - case mSelectedIdentity of - Nothing -> - return (initEarlySecret choice Nothing, False) - Just (PreSharedKeyServerHello 0) -> do - unless (B.length sec == hashSize) $ - throwCore $ Error_Protocol "selected cipher is incompatible with selected PSK" IllegalParameter - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - return (earlySecretPSK, True) - Just _ -> throwCore $ Error_Protocol "selected identity out of range" IllegalParameter - - expectEncryptedExtensions (EncryptedExtensions13 eexts) = do - liftIO $ setALPN ctx MsgTEncryptedExtensions eexts - st <- usingHState ctx getTLS13RTT0Status - if st == RTT0Sent then - case extensionLookup extensionID_EarlyData eexts of - Just _ -> do - usingHState ctx $ setTLS13HandshakeMode RTT0 - usingHState ctx $ setTLS13RTT0Status RTT0Accepted - return (True,eexts) - Nothing -> do - usingHState ctx $ setTLS13HandshakeMode RTT0 - usingHState ctx $ setTLS13RTT0Status RTT0Rejected - return (False,eexts) - else - return (False,eexts) - expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") - - expectCertRequest (CertRequest13 token exts) = do - processCertRequest13 ctx token exts - recvHandshake13 ctx expectCertAndVerify - - expectCertRequest other = do - usingHState ctx $ do - setCertReqToken Nothing - setCertReqCBdata Nothing - -- setCertReqSigAlgsCert Nothing - expectCertAndVerify other - - expectCertAndVerify (Certificate13 _ cc _) = do - _ <- liftIO $ processCertificate cparams ctx (Certificates cc) - let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc - ver <- liftIO $ usingState_ ctx getVersion - checkDigitalSignatureKey ver pubkey - usingHState ctx $ setPublicKey pubkey - recvHandshake13hash ctx $ expectCertVerify pubkey - expectCertAndVerify p = unexpected (show p) (Just "server certificate") - - expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do - ok <- checkCertVerify ctx pubkey sigAlg sig hChSc - unless ok $ decryptError "cannot verify CertificateVerify" - expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") - - expectFinished (ServerTrafficSecret baseKey) hashValue (Finished13 verifyData) = - checkFinished ctx usedHash baseKey hashValue verifyData - expectFinished _ _ p = unexpected (show p) (Just "server finished") - - setResumptionSecret applicationSecret = do - resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret - usingHState ctx $ setTLS13ResumptionSecret resumptionSecret - -processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () -processCertRequest13 ctx token exts = do - let hsextID = extensionID_SignatureAlgorithms - -- caextID = extensionID_SignatureAlgorithmsCert - dNames <- canames - -- The @signature_algorithms@ extension is mandatory. - hsAlgs <- extalgs hsextID unsighash - cTypes <- case hsAlgs of - Just as -> - let validAs = filter isHashSignatureValid13 as - in return $ sigAlgsToCertTypes ctx validAs - Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure - -- Unused: - -- caAlgs <- extalgs caextID uncertsig - usingHState ctx $ do - setCertReqToken $ Just token - setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) - -- setCertReqSigAlgsCert caAlgs - where - canames = case extensionLookup - extensionID_CertificateAuthorities exts of - Nothing -> return [] - Just ext -> case extensionDecode MsgTCertificateRequest ext of - Just (CertificateAuthorities names) -> return names - _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure - extalgs extID decons = case extensionLookup extID exts of - Nothing -> return Nothing - Just ext -> case extensionDecode MsgTCertificateRequest ext of - Just e - -> return $ decons e - _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure - unsighash :: SignatureAlgorithms - -> Maybe [HashAndSignatureAlgorithm] - unsighash (SignatureAlgorithms a) = Just a - {- Unused for now - uncertsig :: SignatureAlgorithmsCert - -> Maybe [HashAndSignatureAlgorithm] - uncertsig (SignatureAlgorithmsCert a) = Just a - -} - -sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO () -sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do - chain <- clientChain cparams ctx - runPacketFlight ctx $ do - case chain of - Nothing -> return () - Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc - rawFinished <- makeFinished ctx usedHash baseKey - loadPacket13 ctx $ Handshake13 [rawFinished] - where - sendClientData13 chain (Just token) = do - let (CertificateChain certs) = chain - certExts = replicate (length certs) [] - cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx - loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] - case certs of - [] -> return () - _ -> do - hChSc <- transcriptHash ctx - pubKey <- getLocalPublicKey ctx - sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey - vfy <- makeCertVerify ctx pubKey sigAlg hChSc - loadPacket13 ctx $ Handshake13 [vfy] - -- - sendClientData13 _ _ = - throwCore $ Error_Protocol "missing TLS 1.3 certificate request context token" InternalError - -setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () -setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of - Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do - mprotos <- getClientALPNSuggest - case mprotos of - Just protos -> when (proto `elem` protos) $ do - setExtensionALPN True - setNegotiatedProtocol proto - _ -> return () - _ -> return () - -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () -postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = - bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - processHandshake13 ctx h - processCertRequest13 ctx certReqCtx exts - (usedHash, _, level, applicationSecretN) <- getTxState ctx - unless (level == CryptApplicationSecret) $ - throwCore $ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage - sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) - -postHandshakeAuthClientWith _ _ _ = - throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthClientWith" UnexpectedMessage - -contextSync :: Context -> ClientState -> IO () -contextSync ctx ctl = case ctxHandshakeSync ctx of - HandshakeSync sync _ -> sync ctx ctl +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Client ( + handshakeClient, + handshakeClientWith, + postHandshakeAuthClientWith, +) where + +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Client.ClientHello +import Network.TLS.Handshake.Client.ServerHello +import Network.TLS.Handshake.Client.TLS12 +import Network.TLS.Handshake.Client.TLS13 +import Network.TLS.Handshake.Common13 +import Network.TLS.Handshake.State +import Network.TLS.Handshake.State13 +import Network.TLS.IO +import Network.TLS.Imports +import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct + +---------------------------------------------------------------- + +handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () +handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx +handshakeClientWith _ _ _ = + throwCore $ + Error_Protocol + "unexpected handshake message received in handshakeClientWith" + HandshakeFailure + +-- 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 + 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 + +-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: +-- "The client will also send a +-- ClientHello when the server has responded to its ClientHello with a +-- HelloRetryRequest. In that case, the client MUST send the same +-- ClientHello without modification, except as follows:" +-- +-- So, the ClientRandom in the first client hello is necessary. +handshake + :: ClientParams + -> Context + -> [Group] + -> Maybe (ClientRandom, Session, Version) + -> IO () +handshake cparams ctx groups mparams = do + -------------------------------- + -- Sending ClientHello + pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx + let async = rtt0 && not (ctxQUICMode ctx) + when async $ do + chSentTime <- getCurrentTimeFromBase + asyncServerHello13 cparams ctx groupToSend chSentTime + updateMeasure ctx incrementNbHandshakes + crand <- sendClientHello cparams ctx groups mparams pskinfo + -------------------------------- + -- Receiving ServerHello + unless async $ do + (ver, hss, 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 + | otherwise -> do + recvServerSecondFlight13 cparams ctx groupToSend + sendClientSecondFlight13 cparams ctx + _ + | rtt0 -> + throwCore $ + Error_Protocol + "server denied TLS 1.3 when connecting with early data" + HandshakeFailure + | otherwise -> do + recvServerFirstFlight12 cparams ctx hss + 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) + +---------------------------------------------------------------- + +helloRetry + :: ClientParams + -> Context + -> Maybe a + -> Version + -> ClientRandom + -> [Group] + -> IO () +helloRetry cparams ctx mparams ver crand groups = do + when (null groups) $ + throwCore $ + Error_Protocol "group is exhausted in 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 + 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)) + | otherwise -> + throwCore $ + Error_Protocol "server-selected group is not supported" IllegalParameter + Just _ -> error "handshake: invalid KeyShare value" + Nothing -> + throwCore $ + Error_Protocol + "key exchange not implemented in HRR, expected key_share extension" + HandshakeFailure diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Client.ClientHello ( + sendClientHello, + getPreSharedKeyInfo, +) where + +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Client.Common +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.IO +import Network.TLS.Imports +import Network.TLS.Packet hiding (getExtensions) +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Types + +---------------------------------------------------------------- + +sendClientHello + :: ClientParams + -> Context + -> [Group] + -> Maybe (ClientRandom, Session, Version) + -> PreSharedKeyInfo + -> IO ClientRandom +sendClientHello cparams ctx groups mparams pskinfo = do + crand <- generateClientHelloParams mparams + sendClientHello' cparams ctx groups crand pskinfo + return crand + where + highestVer = maximum $ supportedVersions $ ctxSupported ctx + tls13 = highestVer >= TLS13 + ems = supportedExtendedMainSecret $ ctxSupported ctx + + -- Client random and session in the second client hello for + -- retry must be the same as the first one. + generateClientHelloParams (Just (crand, clientSession, _)) = do + modifyTLS13State ctx $ \st -> st{tls13stSession = clientSession} + return crand + generateClientHelloParams Nothing = do + crand <- clientRandom ctx + let paramSession = case clientWantSessionResume cparams of + Nothing -> Session Nothing + Just (sidOrTkt, sdata) + | sessionVersion sdata >= TLS13 -> Session Nothing + | ems == RequireEMS && noSessionEMS -> Session Nothing + | isTicket sidOrTkt -> Session $ Just $ toSessionID sidOrTkt + | otherwise -> Session (Just sidOrTkt) + where + noSessionEMS = SessionEMS `notElem` sessionFlags sdata + -- In compatibility mode a client not offering a pre-TLS 1.3 + -- session MUST generate a new 32-byte value + if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx) + then do + randomSession <- newSession ctx + modifyTLS13State ctx $ \st -> st{tls13stSession = randomSession} + return crand + else do + modifyTLS13State ctx $ \st -> st{tls13stSession = paramSession} + return crand + +---------------------------------------------------------------- + +sendClientHello' + :: ClientParams + -> Context + -> [Group] + -> ClientRandom + -> PreSharedKeyInfo + -> IO () +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 + extensions0 <- catMaybes <$> getExtensions + let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0 + extensions <- adjustExtentions extensions1 $ mkClientHello extensions1 + sendPacket12 ctx $ Handshake [mkClientHello extensions] + mEarlySecInfo <- case rtt0info of + Nothing -> return Nothing + Just info -> Just <$> getEarlySecretInfo info + unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo + let sentExtensions = map (\(ExtensionRaw i _) -> i) extensions + 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 + -- are allergic to an extension with empty data at final position. + -- + -- Without TLS 1.3, the list ends with extension "signature_algorithms" + -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions + -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key" + -- (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) + ] + + 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 = + if clientUseServerNameIndication cparams + then do + let sni = fst $ clientServerIdentification cparams + usingState_ ctx $ setClientSNI sni + return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] + else return Nothing + + groupExtension = + return $ + Just $ + toExtensionRaw $ + SupportedGroups (supportedGroups $ ctxSupported ctx) + ecPointExtension = + 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 = + return $ + Just $ + toExtensionRaw $ + SignatureAlgorithms $ + 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 + Nothing -> return Nothing + Just grp -> do + (cpri, ent) <- makeClientKeyShare ctx grp + usingHState ctx $ setGroupPrivate cpri + return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] + | otherwise = return Nothing + + 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 + + pskExchangeModeExtension + | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] + | otherwise = return Nothing + + earlyDataExtension + | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) + | otherwise = return Nothing + + cookieExtension = do + mcookie <- usingState_ ctx getTLS13Cookie + case mcookie of + Nothing -> return Nothing + Just cookie -> return $ Just $ toExtensionRaw cookie + + postHandshakeAuthExtension + | ctxQUICMode ctx = return Nothing + | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth + | otherwise = return Nothing + + adjustExtentions exts ch = + case pskInfo of + Nothing -> return exts + Just (_, sdata, choice, _) -> do + let psk = sessionSecret sdata + earlySecret = initEarlySecret choice (Just psk) + usingHState ctx $ setTLS13EarlySecret earlySecret + let ech = encodeHandshake ch + h = cHash choice + siz = hashDigestSize h + binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) + let exts' = init exts ++ [adjust (last exts)] + adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders + where + withBinders = replacePSKBinder withoutBinders binder + 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 + let clientEarlySecret = pairClient earlyKey + unless (ctxQUICMode ctx) $ do + runPacketFlight ctx $ sendChangeCipherSpec13 ctx + setTxRecordState ctx usedHash usedCipher clientEarlySecret + setEstablished ctx EarlyDataSending + -- We set RTT0Sent even in quicMode + usingHState ctx $ setTLS13RTT0Status RTT0Sent + return $ EarlySecretInfo usedCipher clientEarlySecret + +---------------------------------------------------------------- + +type PreSharedKeyInfo = + (Maybe (SessionID, SessionData, CipherChoice, Second), Maybe CipherChoice, Bool) + +getPreSharedKeyInfo + :: ClientParams + -> Context + -> IO PreSharedKeyInfo +getPreSharedKeyInfo cparams ctx = do + pskInfo <- getPskInfo + let rtt0info = pskInfo >>= get0RTTinfo + rtt0 = isJust rtt0info + return (pskInfo, rtt0info, rtt0) + where + ciphers = supportedCiphers $ ctxSupported ctx + highestVer = maximum $ supportedVersions $ ctxSupported ctx + tls13 = highestVer >= TLS13 + sessionAndCipherToResume13 = do + guard tls13 + (sid, sdata) <- clientWantSessionResume cparams + guard (sessionVersion sdata >= TLS13) + guard (not (null ciphers)) + let sCipher = head ciphers + -- A keyshare is sent only for the first cipher. + -- This can induce HRR. + guard (cipherID sCipher == sessionCipher sdata) + 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 + + get0RTTinfo (_, _, choice, _) + | clientUseEarlyData cparams = Just choice + | otherwise = Nothing diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/Common.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE LambdaCase #-} + +module Network.TLS.Handshake.Client.Common ( + throwMiscErrorOnException, + doServerKeyExchange, + doCertificate, + getLocalHashSigAlg, + clientChain, + sigAlgsToCertTypes, + setALPN, + contextSync, +) where + +import Control.Exception (SomeException) +import Control.Monad.State.Strict +import Data.X509 (ExtKeyUsageFlag (..)) + +import Network.TLS.Cipher +import Network.TLS.Context.Internal +import Network.TLS.Credentials +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Certificate +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Control +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State +import Network.TLS.Imports +import Network.TLS.Packet hiding (getExtensions) +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Util (catchException) +import Network.TLS.X509 + +---------------------------------------------------------------- + +throwMiscErrorOnException :: String -> SomeException -> IO a +throwMiscErrorOnException msg e = + throwCore $ Error_Misc $ msg ++ ": " ++ show e + +---------------------------------------------------------------- + +doServerKeyExchange :: Context -> ServerKeyXchgAlgorithmData -> IO () +doServerKeyExchange ctx origSkx = do + cipher <- usingHState ctx getPendingCipher + processWithCipher cipher origSkx + where + processWithCipher cipher skx = + case (cipherKeyExchange cipher, skx) of + (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> + doDHESignature dhparams signature KX_RSA + (CipherKeyExchange_DHE_DSA, SKX_DHE_DSA dhparams signature) -> + doDHESignature dhparams signature KX_DSA + (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> + doECDHESignature ecdhparams signature KX_RSA + (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> + doECDHESignature ecdhparams signature KX_ECDSA + (cke, SKX_Unparsed bytes) -> do + ver <- usingState_ ctx getVersion + case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of + Left _ -> + throwCore $ + Error_Protocol + ("unknown server key exchange received, expecting: " ++ show cke) + HandshakeFailure + Right realSkx -> processWithCipher cipher realSkx + -- we need to resolve the result. and recall processWithCipher .. + (c, _) -> + throwCore $ + Error_Protocol + ("unknown server key exchange received, expecting: " ++ show c) + HandshakeFailure + doDHESignature dhparams signature kxsAlg = do + -- FF group selected by the server is verified when generating CKX + publicKey <- getSignaturePublicKey kxsAlg + verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature + unless verified $ + decryptError + ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) + usingHState ctx $ setServerDHParams dhparams + + doECDHESignature ecdhparams signature kxsAlg = do + -- EC group selected by the server is verified when generating CKX + publicKey <- getSignaturePublicKey kxsAlg + verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature + unless verified $ + decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") + usingHState ctx $ setServerECDHParams ecdhparams + + getSignaturePublicKey kxsAlg = do + publicKey <- usingHState ctx getRemotePublicKey + unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ + throwCore $ + Error_Protocol + ("server public key algorithm is incompatible with " ++ show kxsAlg) + HandshakeFailure + ver <- usingState_ ctx getVersion + unless (publicKey `versionCompatible` ver) $ + throwCore $ + Error_Protocol + (show ver ++ " has no support for " ++ pubkeyType publicKey) + IllegalParameter + let groups = supportedGroups (ctxSupported ctx) + unless (satisfiesEcPredicate (`elem` groups) publicKey) $ + throwCore $ + Error_Protocol + "server public key has unsupported elliptic curve" + IllegalParameter + return publicKey + +---------------------------------------------------------------- + +doCertificate :: ClientParams -> Context -> CertificateChain -> IO () +doCertificate cparams ctx certs = do + when (isNullCertificateChain certs) $ + throwCore $ + Error_Protocol "server certificate missing" DecodeError + -- run certificate recv hook + ctxWithHooks ctx (`hookRecvCertificates` certs) + -- then run certificate validation + usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException + case usage of + CertificateUsageAccept -> checkLeafCertificateKeyUsage + CertificateUsageReject reason -> certificateRejected reason + where + shared = clientShared cparams + checkCert = + onServerCertificate + (clientHooks cparams) + (sharedCAStore shared) + (sharedValidationCache shared) + (clientServerIdentification cparams) + certs + -- also verify that the certificate optional key usage is compatible + -- with the intended key-exchange. This check is not delegated to + -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated + -- cipher, which is not available from onServerCertificate parameters. + -- Additionally, with only one shared ValidationCache, x509-validation + -- would cache validation result based on a key usage and reuse it with + -- another key usage. + checkLeafCertificateKeyUsage = do + cipher <- usingHState ctx getPendingCipher + case requiredCertKeyUsage cipher of + [] -> return () + flags -> verifyLeafKeyUsage flags certs + +-- Unless result is empty, server certificate must be allowed for at least one +-- of the returned values. Constraints for RSA-based key exchange are relaxed +-- to avoid rejecting certificates having incomplete extension. +requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag] +requiredCertKeyUsage cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> rsaCompatibility + CipherKeyExchange_DH_Anon -> [] -- unrestricted + CipherKeyExchange_DHE_RSA -> rsaCompatibility + CipherKeyExchange_ECDHE_RSA -> rsaCompatibility + CipherKeyExchange_DHE_DSA -> [KeyUsage_digitalSignature] + CipherKeyExchange_DH_DSA -> [KeyUsage_keyAgreement] + CipherKeyExchange_DH_RSA -> rsaCompatibility + CipherKeyExchange_ECDH_ECDSA -> [KeyUsage_keyAgreement] + CipherKeyExchange_ECDH_RSA -> rsaCompatibility + CipherKeyExchange_ECDHE_ECDSA -> [KeyUsage_digitalSignature] + CipherKeyExchange_TLS13 -> [KeyUsage_digitalSignature] + where + rsaCompatibility = + [ KeyUsage_digitalSignature + , KeyUsage_keyEncipherment + , KeyUsage_keyAgreement + ] + +---------------------------------------------------------------- + +-- | Return the supported 'CertificateType' values that are +-- compatible with at least one supported signature algorithm. +supportedCtypes + :: [HashAndSignatureAlgorithm] + -> [CertificateType] +supportedCtypes hashAlgs = + nub $ foldr ctfilter [] hashAlgs + where + ctfilter x acc = case hashSigToCertType x of + Just cType + | cType <= lastSupportedCertificateType -> + cType : acc + _ -> acc + +clientSupportedCtypes + :: Context + -> [CertificateType] +clientSupportedCtypes ctx = + supportedCtypes $ supportedHashSignatures $ ctxSupported ctx + +sigAlgsToCertTypes + :: Context + -> [HashAndSignatureAlgorithm] + -> [CertificateType] +sigAlgsToCertTypes ctx hashSigs = + filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx + +---------------------------------------------------------------- + +-- | When the server requests a client certificate, we try to +-- obtain a suitable certificate chain and private key via the +-- callback in the client parameters. It is OK for the callback +-- to return an empty chain, in many cases the client certificate +-- is optional. If the client wishes to abort the handshake for +-- lack of a suitable certificate, it can throw an exception in +-- the callback. +-- +-- The return value is 'Nothing' when no @CertificateRequest@ was +-- received and no @Certificate@ message needs to be sent. An empty +-- chain means that an empty @Certificate@ message needs to be sent +-- to the server, naturally without a @CertificateVerify@. A non-empty +-- 'CertificateChain' is the chain to send to the server along with +-- a corresponding 'CertificateVerify'. +-- +-- With TLS < 1.2 the server's @CertificateRequest@ does not carry +-- a signature algorithm list. It has a list of supported public +-- key signing algorithms in the @certificate_types@ field. The +-- hash is implicit. It is 'SHA1' for DSA and 'SHA1_MD5' for RSA. +-- +-- With TLS == 1.2 the server's @CertificateRequest@ always has a +-- @supported_signature_algorithms@ list, as a fixed component of +-- the structure. This list is (wrongly) overloaded to also limit +-- X.509 signatures in the client's certificate chain. The BCP +-- strategy is to find a compatible chain if possible, but else +-- ignore the constraint, and let the server verify the chain as it +-- sees fit. The @supported_signature_algorithms@ field is only +-- obligatory with respect to signatures on TLS messages, in this +-- case the @CertificateVerify@ message. The @certificate_types@ +-- field is still included. +-- +-- With TLS 1.3 the server's @CertificateRequest@ has a mandatory +-- @signature_algorithms@ extension, the @signature_algorithms_cert@ +-- extension, which is optional, carries a list of algorithms the +-- server promises to support in verifying the certificate chain. +-- As with TLS 1.2, the client's makes a /best-effort/ to deliver +-- a compatible certificate chain where all the CA signatures are +-- known to be supported, but it should not abort the connection +-- just because the chain might not work out, just send the best +-- chain you have and let the server worry about the rest. The +-- supported public key algorithms are now inferred from the +-- @signature_algorithms@ extension and @certificate_types@ is +-- gone. +-- +-- With TLS 1.3, we synthesize and store a @certificate_types@ +-- field at the time that the server's @CertificateRequest@ +-- message is received. This is then present across all the +-- protocol versions, and can be used to determine whether +-- a @CertificateRequest@ was received or not. +-- +-- If @signature_algorithms@ is 'Nothing', then we're doing +-- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension +-- is optional in TLS 1.3, and so the application callback +-- will not be able to distinguish between TLS 1.[01] and +-- TLS 1.3 with no certificate algorithm hints, but this +-- just simplifies the chain selection process, all CA +-- signatures are OK. +clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain) +clientChain cparams ctx = + usingHState ctx getCertReqCBdata >>= \case + Nothing -> return Nothing + Just cbdata -> do + let callback = onCertificateRequest $ clientHooks cparams + chain <- + liftIO $ + callback cbdata + `catchException` throwMiscErrorOnException "certificate request callback failed" + case chain of + Nothing -> + return $ Just $ CertificateChain [] + Just (CertificateChain [], _) -> + return $ Just $ CertificateChain [] + Just cred@(cc, _) -> + do + let (cTypes, _, _) = cbdata + storePrivInfoClient ctx cTypes cred + return $ Just cc + +-- | Store the keypair and check that it is compatible with the current protocol +-- version and a list of 'CertificateType' values. +storePrivInfoClient + :: Context + -> [CertificateType] + -> Credential + -> IO () +storePrivInfoClient ctx cTypes (cc, privkey) = do + pubkey <- storePrivInfo ctx cc privkey + unless (certificateCompatible pubkey cTypes) $ + throwCore $ + Error_Protocol + (pubkeyType pubkey ++ " credential does not match allowed certificate types") + InternalError + ver <- usingState_ ctx getVersion + unless (pubkey `versionCompatible` ver) $ + throwCore $ + Error_Protocol + (pubkeyType pubkey ++ " credential is not supported at version " ++ show ver) + InternalError + +---------------------------------------------------------------- + +-- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with +-- the local key and server's signature algorithms (both already saved). Must +-- only be called for TLS versions 1.2 and up, with compatibility function +-- 'signatureCompatible' or 'signatureCompatible13' based on version. +-- +-- The values in the server's @signature_algorithms@ extension are +-- in descending order of preference. However here the algorithms +-- are selected by client preference in @cHashSigs@. +getLocalHashSigAlg + :: Context + -> (PubKey -> HashAndSignatureAlgorithm -> Bool) + -> [HashAndSignatureAlgorithm] + -> PubKey + -> IO HashAndSignatureAlgorithm +getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do + -- Must be present with TLS 1.2 and up. + (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata + let want = + (&&) + <$> isCompatible pubKey + <*> flip elem hashSigs + case find want cHashSigs of + Just best -> return best + Nothing -> throwCore $ Error_Protocol (keyerr pubKey) HandshakeFailure + where + keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" + +---------------------------------------------------------------- + +setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () +setALPN ctx msgt exts = case extensionLookup EID_ApplicationLayerProtocolNegotiation exts + >>= extensionDecode msgt of + Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do + mprotos <- getClientALPNSuggest + case mprotos of + Just protos -> when (proto `elem` protos) $ do + setExtensionALPN True + setNegotiatedProtocol proto + _ -> return () + _ -> return () + +---------------------------------------------------------------- + +contextSync :: Context -> ClientState -> IO () +contextSync ctx ctl = case ctxHandshakeSync ctx of + HandshakeSync sync _ -> sync ctx ctl diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Client.ServerHello ( + recvServerHello, + processServerHello13, +) where + +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Context.Internal +import Network.TLS.ErrT +import Network.TLS.Extension +import Network.TLS.Handshake.Client.Common +import Network.TLS.Handshake.Common +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.IO +import Network.TLS.Imports +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types + +---------------------------------------------------------------- + +recvServerHello + :: ClientParams -> Context -> IO [Handshake] +recvServerHello cparams ctx = do + (sh, hss) <- recvSH + processServerHello cparams ctx sh + processHandshake12 ctx sh + return hss + where + recvSH = do + epkt <- recvPacket12 ctx + case epkt of + Left e -> throwCore e + Right pkt -> case pkt of + Alert a -> throwAlert a + Handshake (h : hs) -> return (h, hs) + _ -> unexpected (show pkt) (Just "handshake") + throwAlert a = + throwCore $ + Error_Protocol + ("expecting server hello, got alert : " ++ show a) + HandshakeFailure + +---------------------------------------------------------------- + +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 _ _ 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 +-- 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 +processServerHello + :: ClientParams -> Context -> Handshake -> IO () +processServerHello cparams ctx (ServerHello rver serverRan serverSession cipher compression exts) = do + when (rver < TLS12) $ + throwCore $ + Error_Protocol (show rver ++ " is not supported") ProtocolVersion + -- 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 + Nothing -> throwCore $ Error_Protocol "server choose unknown cipher" IllegalParameter + Just alg -> return alg + compressAlg <- case find + ((==) compression . compressionID) + (supportedCompressions $ ctxSupported ctx) of + Nothing -> + throwCore $ Error_Protocol "server choose unknown compression" IllegalParameter + Just alg -> return alg + ensureNullCompression compression + + -- 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) $ + throwCore $ + Error_Protocol "spurious extensions received" UnsupportedExtension + + let isHRR = isHelloRetryRequest serverRan + 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 + + setALPN ctx MsgTServerHello exts + + ver <- usingState_ ctx getVersion + + when (ver == TLS12) $ do + usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg + + let supportedVers = supportedVersions $ clientSupported cparams + + when (ver == TLS13) $ do + when (clientSession /= serverSession) $ + throwCore $ + Error_Protocol + "session is not matched in compatibility mode" + IllegalParameter + when (ver `notElem` supportedVers) $ + throwCore $ + Error_Protocol + ("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. + -- + when (isDowngraded ver supportedVers serverRan) $ + 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 +processServerHello _ _ p = unexpected (show p) (Just "server hello") + +---------------------------------------------------------------- + +processServerExtension :: ExtensionRaw -> TLSSt () +processServerExtension (ExtensionRaw extID content) + | extID == EID_SecureRenegotiation = do + cvd <- getVerifyData ClientRole + svd <- getVerifyData ServerRole + let bs = extensionEncode $ SecureRenegotiation cvd svd + unless (bs == content) $ + throwError $ + Error_Protocol "server secure renegotiation data not matching" HandshakeFailure + | extID == EID_SupportedVersions = case extensionDecode MsgTServerHello content of + Just (SupportedVersionsServerHello ver) -> setVersion ver + _ -> return () + | extID == EID_KeyShare = do + hrr <- getTLS13HRR + let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello + setTLS13KeyShare $ extensionDecode msgt content + | extID == EID_PreSharedKey = + setTLS13PreSharedKey $ extensionDecode MsgTServerHello content + | extID == EID_SessionTicket = setTLS12SessionTicket "" -- empty ticket +processServerExtension _ = return () + +---------------------------------------------------------------- + +updateContext13 :: Context -> Cipher -> IO () +updateContext13 ctx cipherAlg = do + established <- ctxEstablished ctx + eof <- ctxEOF ctx + when (established == Established && not eof) $ + throwCore $ + Error_Protocol + "renegotiation to TLS 1.3 or later is not allowed" + ProtocolVersion + failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg + +updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO () +updateContext12 ctx exts resumingSession = do + ems <- processExtendedMainSecret ctx TLS12 MsgTServerHello exts + case resumingSession of + Nothing -> return () + Just sessionData -> do + let emsSession = SessionEMS `elem` sessionFlags sessionData + when (ems /= emsSession) $ + let err = "server resumes a session which is not EMS consistent" + in throwCore $ Error_Protocol err HandshakeFailure + let mainSecret = sessionSecret sessionData + usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret + logKey ctx (MainSecret mainSecret) diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Client.TLS12 ( + recvServerFirstFlight12, + sendClientSecondFlight12, + recvServerSecondFlight12, +) where + +import Control.Monad.State.Strict +import qualified Data.ByteString as B + +import Network.TLS.Cipher +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Handshake.Client.Common +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State +import Network.TLS.IO +import Network.TLS.Imports +import Network.TLS.Packet hiding (getExtensions, getSession) +import Network.TLS.Parameters +import Network.TLS.Session +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Types +import Network.TLS.Util (catchException) +import Network.TLS.Wire +import Network.TLS.X509 hiding (Certificate) + +---------------------------------------------------------------- + +recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO () +recvServerFirstFlight12 cparams ctx hs = do + resuming <- usingState_ ctx isSessionResuming + if resuming + then recvNSTandCCSandFinished ctx + else do + let st = RecvStateHandshake (expectCertificate cparams ctx) + runRecvStateHS ctx st hs + +expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) +expectCertificate cparams ctx (Certificate certs) = do + usingState_ ctx $ setServerCertificateChain certs + doCertificate cparams ctx certs + processCertificate ctx ClientRole certs + return $ RecvStateHandshake (expectServerKeyExchange ctx) +expectCertificate _ ctx p = expectServerKeyExchange ctx p + +expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) +expectServerKeyExchange ctx (ServerKeyXchg origSkx) = do + doServerKeyExchange ctx origSkx + return $ RecvStateHandshake (expectCertificateRequest ctx) +expectServerKeyExchange ctx p = expectCertificateRequest ctx p + +expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO) +expectCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do + let cTypes = filter (<= lastSupportedCertificateType) cTypesSent + usingHState ctx $ setCertReqCBdata $ Just (cTypes, Just sigAlgs, dNames) + return $ RecvStateHandshake (expectServerHelloDone ctx) +expectCertificateRequest ctx p = do + usingHState ctx $ setCertReqCBdata Nothing + expectServerHelloDone ctx p + +expectServerHelloDone :: Context -> Handshake -> IO (RecvState m) +expectServerHelloDone _ ServerHelloDone = return RecvStateDone +expectServerHelloDone _ p = unexpected (show p) (Just "server hello data") + +---------------------------------------------------------------- + +sendClientSecondFlight12 :: ClientParams -> Context -> IO () +sendClientSecondFlight12 cparams ctx = do + sessionResuming <- usingState_ ctx isSessionResuming + if sessionResuming + then sendCCSandFinished ctx ClientRole + else do + sendClientCCC cparams ctx + sendCCSandFinished ctx ClientRole + +recvServerSecondFlight12 :: Context -> IO () +recvServerSecondFlight12 ctx = do + sessionResuming <- usingState_ ctx isSessionResuming + 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 + +recvNSTandCCSandFinished :: Context -> IO () +recvNSTandCCSandFinished ctx = do + st <- isJust <$> usingState_ ctx getTLS12SessionTicket + if st + then runRecvState ctx $ RecvStateHandshake expectNewSessionTicket + else do runRecvState ctx $ RecvStatePacket expectChangeCipher + where + expectNewSessionTicket (NewSessionTicket _ ticket) = do + usingState_ ctx $ setTLS12SessionTicket ticket + return $ RecvStatePacket expectChangeCipher + expectNewSessionTicket p = unexpected (show p) (Just "Handshake Finished") + + expectChangeCipher ChangeCipherSpec = do + return $ RecvStateHandshake $ expectFinished ctx + expectChangeCipher p = unexpected (show p) (Just "change cipher") + +---------------------------------------------------------------- + +-- | TLS 1.2 and below. Send the client handshake messages that +-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@. +-- +-- XXX: Is any buffering done here to combined these messages into +-- a single TCP packet? Otherwise we're prone to Nagle delays, or +-- in any case needlessly generate multiple small packets, where +-- a single larger packet will do. The TLS 1.3 code path seems +-- to separating record generation and transmission and sending +-- multiple records in a single packet. +-- +-- -> [certificate] +-- -> client key exchange +-- -> [cert verify] +sendClientCCC :: ClientParams -> Context -> IO () +sendClientCCC cparams ctx = do + sendCertificate cparams ctx + sendClientKeyXchg cparams ctx + sendCertificateVerify ctx + +---------------------------------------------------------------- + +sendCertificate :: ClientParams -> Context -> IO () +sendCertificate cparams ctx = do + usingHState ctx $ setClientCertSent False + clientChain cparams ctx >>= \case + Nothing -> return () + Just cc@(CertificateChain certs) -> do + unless (null certs) $ + usingHState ctx $ + setClientCertSent True + sendPacket12 ctx $ Handshake [Certificate cc] + +---------------------------------------------------------------- + +sendClientKeyXchg :: ClientParams -> Context -> IO () +sendClientKeyXchg cparams ctx = do + cipher <- usingHState ctx getPendingCipher + (ckx, setMainSec) <- case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> getCKX_RSA ctx + CipherKeyExchange_DHE_RSA -> getCKX_DHE cparams ctx + CipherKeyExchange_DHE_DSA -> getCKX_DHE cparams ctx + CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE ctx + CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE ctx + _ -> + throwCore $ + Error_Protocol "client key exchange unsupported type" HandshakeFailure + sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] + mainSecret <- usingHState ctx setMainSec + logKey ctx (MainSecret mainSecret) + +-------------------------------- + +getCKX_RSA + :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) +getCKX_RSA ctx = do + clientVersion <- usingHState ctx $ gets hstClientVersion + (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 + + let preMain = encodePreMainSecret clientVersion prerand + setMainSec = setMainSecretFromPre xver ClientRole preMain + encryptedPreMain <- do + -- SSL3 implementation generally forget this length field since it's redundant, + -- however TLS10 make it clear that the length field need to be present. + e <- encryptRSA ctx preMain + let extra = encodeWord16 $ fromIntegral $ B.length e + return $ extra `B.append` e + return (CKX_RSA encryptedPreMain, setMainSec) + +-------------------------------- + +getCKX_DHE + :: ClientParams + -> Context + -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) +getCKX_DHE cparams ctx = do + xver <- usingState_ ctx getVersion + serverParams <- usingHState ctx getServerDHParams + + let params = serverDHParamsToParams serverParams + ffGroup = findFiniteFieldGroup params + srvpub = serverDHParamsToPublic serverParams + + unless (maybe False (isSupportedGroup ctx) ffGroup) $ do + groupUsage <- + onCustomFFDHEGroup (clientHooks cparams) params srvpub + `catchException` throwMiscErrorOnException "custom group callback failed" + case groupUsage of + GroupUsageInsecure -> + throwCore $ + Error_Protocol "FFDHE group is not secure enough" InsufficientSecurity + GroupUsageUnsupported reason -> + throwCore $ + Error_Protocol ("unsupported FFDHE group: " ++ reason) HandshakeFailure + GroupUsageInvalidPublic -> throwCore $ Error_Protocol "invalid server public key" IllegalParameter + GroupUsageValid -> return () + + -- When grp is known but not in the supported list we use it + -- anyway. This provides additional validation and a more + -- efficient implementation. + (clientDHPub, preMain) <- + case ffGroup of + Nothing -> do + (clientDHPriv, clientDHPub) <- generateDHE ctx params + let preMain = dhGetShared params clientDHPriv srvpub + return (clientDHPub, preMain) + Just grp -> do + usingHState ctx $ setSupportedGroup grp + dhePair <- generateFFDHEShared ctx grp srvpub + case dhePair of + Nothing -> + throwCore $ + Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter + Just pair -> return pair + + let setMainSec = setMainSecretFromPre xver ClientRole preMain + return (CKX_DH clientDHPub, setMainSec) + +-------------------------------- + +getCKX_ECDHE + :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString) +getCKX_ECDHE ctx = do + ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams + checkSupportedGroup ctx grp + usingHState ctx $ setSupportedGroup grp + ecdhePair <- generateECDHEShared ctx srvpub + case ecdhePair of + Nothing -> + throwCore $ + Error_Protocol ("invalid server " ++ show grp ++ " public key") IllegalParameter + Just (clipub, preMain) -> do + xver <- usingState_ ctx getVersion + let setMainSec = setMainSecretFromPre xver ClientRole preMain + return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec) + +---------------------------------------------------------------- + +-- In order to send a proper certificate verify message, +-- we have to do the following: +-- +-- 1. Determine which signing algorithm(s) the server supports +-- (we currently only support RSA). +-- 2. Get the current handshake hash from the handshake state. +-- 3. Sign the handshake hash +-- 4. Send it to the server. +-- +sendCertificateVerify :: Context -> IO () +sendCertificateVerify ctx = do + ver <- usingState_ ctx getVersion + + -- Only send a certificate verify message when we + -- have sent a non-empty list of certificates. + -- + certSent <- usingHState ctx getClientCertSent + when certSent $ do + pubKey <- getLocalPublicKey ctx + mhashSig <- + let cHashSigs = supportedHashSignatures $ ctxSupported ctx + in getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey + -- 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] diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Client.TLS13 ( + recvServerSecondFlight13, + sendClientSecondFlight13, + asyncServerHello13, + postHandshakeAuthClientWith, +) where + +import Control.Exception (bracket) +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.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Client.Common +import Network.TLS.Handshake.Client.ServerHello +import Network.TLS.Handshake.Common hiding (expectFinished) +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.IO +import Network.TLS.Imports +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types +import Network.TLS.X509 + +---------------------------------------------------------------- +---------------------------------------------------------------- + +recvServerSecondFlight13 :: ClientParams -> Context -> Maybe 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 + +---------------------------------------------------------------- + +prepareSecondFlight13 + :: Context -> Maybe Group -> IO Bool +prepareSecondFlight13 ctx groupSent = do + choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher + prepareSecondFlight13' ctx groupSent choice + +prepareSecondFlight13' + :: Context + -> Maybe Group + -> CipherChoice + -> IO Bool +prepareSecondFlight13' ctx groupSent choice = do + (_, hkey, resuming) <- switchToHandshakeSecret + let clientHandshakeSecret = triClient hkey + serverHandshakeSecret = triServer hkey + handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) + contextSync ctx $ RecvServerHello handSecInfo + modifyTLS13State ctx $ \st -> + st + { tls13stChoice = choice + , tls13stHsKey = Just hkey + } + return resuming + where + usedCipher = cCipher choice + usedHash = cHash choice + + hashSize = hashDigestSize usedHash + + switchToHandshakeSecret = do + ensureRecvComplete ctx + ecdhe <- calcSharedKey + (earlySecret, resuming) <- makeEarlySecret + handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe + let serverHandshakeSecret = triServer handKey + setRxRecordState ctx usedHash usedCipher serverHandshakeSecret + return (usedCipher, handKey, resuming) + + calcSharedKey = do + serverKeyShare <- do + mks <- usingState_ ctx getTLS13KeyShare + case mks of + Just (KeyShareServerHello ks) -> return ks + Just _ -> + throwCore $ Error_Protocol "invalid key_share value" IllegalParameter + Nothing -> + throwCore $ + Error_Protocol + "key exchange not implemented, expected key_share extension" + HandshakeFailure + let grp = keyShareEntryGroup serverKeyShare + unless (checkKeyShareKeyLength serverKeyShare) $ + throwCore $ + Error_Protocol "broken key_share" IllegalParameter + unless (groupSent == Just grp) $ + throwCore $ + Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter + usingHState ctx $ setSupportedGroup grp + usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare + + makeEarlySecret = do + mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret + case mEarlySecretPSK of + Nothing -> return (initEarlySecret choice Nothing, False) + Just earlySecretPSK@(BaseSecret sec) -> do + mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey + case mSelectedIdentity of + Nothing -> + return (initEarlySecret choice Nothing, False) + Just (PreSharedKeyServerHello 0) -> do + unless (B.length sec == hashSize) $ + throwCore $ + Error_Protocol + "selected cipher is incompatible with selected PSK" + IllegalParameter + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + return (earlySecretPSK, True) + Just _ -> + throwCore $ Error_Protocol "selected identity out of range" IllegalParameter + +---------------------------------------------------------------- + +expectEncryptedExtensions + :: MonadIO m => Context -> Handshake13 -> m () +expectEncryptedExtensions ctx (EncryptedExtensions13 eexts) = do + liftIO $ do + setALPN ctx MsgTEncryptedExtensions eexts + modifyTLS13State ctx $ \st -> st{tls13stClientExtensions = eexts} + st13 <- usingHState ctx getTLS13RTT0Status + when (st13 == RTT0Sent) $ + case extensionLookup EID_EarlyData eexts of + Just _ -> do + usingHState ctx $ setTLS13HandshakeMode RTT0 + usingHState ctx $ setTLS13RTT0Status RTT0Accepted + liftIO $ modifyTLS13State ctx $ \st -> st{tls13st0RTTAccepted = True} + Nothing -> do + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + usingHState ctx $ setTLS13RTT0Status RTT0Rejected +expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions") + +---------------------------------------------------------------- +-- not used in 0-RTT +expectCertRequest + :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () +expectCertRequest cparams ctx (CertRequest13 token exts) = do + processCertRequest13 ctx token exts + recvHandshake13 ctx $ expectCertAndVerify cparams ctx +expectCertRequest cparams ctx other = do + usingHState ctx $ do + setCertReqToken Nothing + setCertReqCBdata Nothing + -- setCertReqSigAlgsCert Nothing + expectCertAndVerify cparams ctx other + +processCertRequest13 + :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () +processCertRequest13 ctx token exts = do + let hsextID = EID_SignatureAlgorithms + -- caextID = EID_SignatureAlgorithmsCert + dNames <- canames + -- The @signature_algorithms@ extension is mandatory. + hsAlgs <- extalgs hsextID unsighash + cTypes <- case hsAlgs of + Just as -> + let validAs = filter isHashSignatureValid13 as + in return $ sigAlgsToCertTypes ctx validAs + Nothing -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure + -- Unused: + -- caAlgs <- extalgs caextID uncertsig + usingHState ctx $ do + setCertReqToken $ Just token + setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) + where + -- setCertReqSigAlgsCert caAlgs + + canames = case extensionLookup + EID_CertificateAuthorities + exts of + Nothing -> return [] + Just ext -> case extensionDecode MsgTCertificateRequest ext of + Just (CertificateAuthorities names) -> return names + _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure + extalgs extID decons = case extensionLookup extID exts of + Nothing -> return Nothing + Just ext -> case extensionDecode MsgTCertificateRequest ext of + Just e -> + return $ decons e + _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure + unsighash + :: SignatureAlgorithms + -> Maybe [HashAndSignatureAlgorithm] + unsighash (SignatureAlgorithms a) = Just a + +---------------------------------------------------------------- +-- not used in 0-RTT +expectCertAndVerify + :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () +expectCertAndVerify cparams ctx (Certificate13 _ 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") + +---------------------------------------------------------------- + +expectCertVerify + :: MonadIO m => Context -> PubKey -> ByteString -> Handshake13 -> m () +expectCertVerify ctx pubkey hChSc (CertVerify13 sigAlg sig) = do + ok <- checkCertVerify ctx pubkey sigAlg sig hChSc + unless ok $ decryptError "cannot verify CertificateVerify" +expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify") + +---------------------------------------------------------------- + +expectFinished + :: MonadIO m + => Context + -> ByteString + -> Handshake13 + -> m () +expectFinished 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 $ modifyTLS13State ctx $ \s -> s{tls13stRecvSF = True} +expectFinished _ _ p = unexpected (show p) (Just "server finished") + +---------------------------------------------------------------- +---------------------------------------------------------------- + +sendClientSecondFlight13 :: ClientParams -> Context -> IO () +sendClientSecondFlight13 cparams ctx = do + st <- getTLS13State ctx + let choice = tls13stChoice st + hkey = fromJust $ tls13stHsKey st + rtt0accepted = tls13st0RTTAccepted st + eexts = tls13stClientExtensions st + sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts + modifyTLS13State ctx $ \s -> s{tls13stSentCF = True} + +sendClientSecondFlight13' + :: ClientParams + -> Context + -> CipherChoice + -> SecretTriple HandshakeSecret + -> Bool + -> [ExtensionRaw] + -> IO () +sendClientSecondFlight13' cparams ctx choice hkey rtt0accepted eexts = do + hChSf <- transcriptHash ctx + unless (ctxQUICMode ctx) $ + runPacketFlight ctx $ + sendChangeCipherSpec13 ctx + when (rtt0accepted && not (ctxQUICMode ctx)) $ + sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) + let clientHandshakeSecret = triClient hkey + setTxRecordState ctx usedHash usedCipher clientHandshakeSecret + sendClientFlight13 cparams ctx usedHash clientHandshakeSecret + appKey <- switchToApplicationSecret hChSf + let applicationSecret = triBase appKey + setResumptionSecret applicationSecret + let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) + contextSync ctx $ SendClientFinished eexts appSecInfo + modifyTLS13State ctx $ \st -> st{tls13stHsKey = Nothing} + handshakeDone13 ctx + builder <- tls13stPendingSentData <$> getTLS13State ctx + modifyTLS13State ctx $ \st -> st{tls13stPendingSentData = id} + unless rtt0accepted $ + mapM_ (sendPacket13 ctx . AppData13) $ + builder [] + where + usedCipher = cCipher choice + usedHash = cHash choice + + switchToApplicationSecret hChSf = do + ensureRecvComplete ctx + let handshakeSecret = triBase hkey + appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf + let serverApplicationSecret0 = triServer appKey + let clientApplicationSecret0 = triClient appKey + setTxRecordState ctx usedHash usedCipher clientApplicationSecret0 + setRxRecordState ctx usedHash usedCipher serverApplicationSecret0 + return appKey + + setResumptionSecret applicationSecret = do + resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret + usingHState ctx $ setTLS13ResumptionSecret resumptionSecret + +{- Unused for now +uncertsig :: SignatureAlgorithmsCert + -> Maybe [HashAndSignatureAlgorithm] +uncertsig (SignatureAlgorithmsCert a) = Just a +-} + +sendClientFlight13 + :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO () +sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do + mcc <- clientChain cparams ctx + runPacketFlight ctx $ do + case mcc of + Nothing -> return () + Just cc -> usingHState ctx getCertReqToken >>= loadClientData13 cc + rawFinished <- makeFinished ctx usedHash baseKey + loadPacket13 ctx $ Handshake13 [rawFinished] + when (isJust mcc) $ + modifyTLS13State ctx $ + \st -> st{tls13stSentClientCert = True} + where + loadClientData13 chain (Just token) = do + let (CertificateChain certs) = chain + certExts = replicate (length certs) [] + cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx + loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] + case certs of + [] -> return () + _ -> do + hChSc <- transcriptHash ctx + pubKey <- getLocalPublicKey ctx + sigAlg <- + liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey + vfy <- makeCertVerify ctx pubKey sigAlg hChSc + loadPacket13 ctx $ Handshake13 [vfy] + -- + 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) = + bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do + processHandshake13 ctx h + processCertRequest13 ctx certReqCtx exts + (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx + unless (level == CryptApplicationSecret) $ + throwCore $ + Error_Protocol + "unexpected post-handshake authentication request" + UnexpectedMessage + sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) +postHandshakeAuthClientWith _ _ _ = + throwCore $ + Error_Protocol + "unexpected handshake message received in postHandshakeAuthClientWith" + UnexpectedMessage + +---------------------------------------------------------------- +---------------------------------------------------------------- + +asyncServerHello13 + :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO () +asyncServerHello13 cparams ctx groupSent chSentTime = do + setPendingRecvActions + ctx + [ PendingRecvAction True expectServerHello + , PendingRecvAction + True + (expectEncryptedExtensions ctx) + , PendingRecvActionHash + True + expectFinishedAndSet + ] + where + expectServerHello sh = do + setRTT ctx chSentTime + processServerHello13 cparams ctx sh + void $ prepareSecondFlight13 ctx groupSent + expectFinishedAndSet h sf = do + expectFinished ctx h sf + liftIO $ + writeIORef (ctxPendingSendAction ctx) $ + Just $ + sendClientSecondFlight13 cparams diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -1,58 +1,61 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Network.TLS.Handshake.Common - ( handshakeFailed - , handleException - , unexpected - , newSession - , handshakeTerminate + +module Network.TLS.Handshake.Common ( + handshakeFailed, + handleException, + unexpected, + newSession, + handshakeDone12, + ensureNullCompression, + -- * sending packets - , sendChangeCipherAndFinish + sendCCSandFinished, + -- * receiving packets - , recvChangeCipherAndFinish - , RecvState(..) - , runRecvState - , recvPacketHandshake - , onRecvStateHandshake - , ensureRecvComplete - , processExtendedMasterSec - , extensionLookup - , getSessionData - , storePrivInfo - , isSupportedGroup - , checkSupportedGroup - , errorToAlert - , errorToAlertMessage - ) where + RecvState (..), + runRecvState, + runRecvStateHS, + recvPacketHandshake, + onRecvStateHandshake, + ensureRecvComplete, + processExtendedMainSecret, + extensionLookup, + getSessionData, + storePrivInfo, + isSupportedGroup, + checkSupportedGroup, + errorToAlert, + errorToAlertMessage, + expectFinished, + processCertificate, +) where -import qualified Data.ByteString as B import Control.Concurrent.MVar +import Control.Exception (IOException, fromException, handle, throwIO) +import Control.Monad.State.Strict -import Network.TLS.Parameters +import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal +import Network.TLS.Crypto import Network.TLS.Extension -import Network.TLS.Session -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.IO -import Network.TLS.State import Network.TLS.Handshake.Key import Network.TLS.Handshake.Process +import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State -import Network.TLS.Record.State +import Network.TLS.Handshake.State13 +import Network.TLS.IO +import Network.TLS.Imports import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Types -import Network.TLS.Cipher -import Network.TLS.Crypto import Network.TLS.Util import Network.TLS.X509 -import Network.TLS.Imports -import Control.Monad.State.Strict -import Control.Exception (IOException, handle, fromException, throwIO) -import Data.IORef (writeIORef) - handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err @@ -62,100 +65,91 @@ -- 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) + Just e | Uncontextualized e' <- e -> e' + _ -> Error_Misc (show exception) + established <- ctxEstablished ctx setEstablished ctx NotEstablished handle ignoreIOErr $ do tls13 <- tls13orLater ctx - if tls13 then - sendPacket13 ctx $ Alert13 [errorToAlert tlserror] - else - sendPacket ctx $ Alert [errorToAlert tlserror] + if tls13 + then do + when (established == EarlyDataSending) $ clearTxRecordState ctx + sendPacket13 ctx $ Alert13 [errorToAlert tlserror] + else sendPacket12 ctx $ Alert [errorToAlert tlserror] handshakeFailed tlserror where ignoreIOErr :: IOException -> IO () ignoreIOErr _ = return () errorToAlert :: TLSError -> (AlertLevel, AlertDescription) -errorToAlert (Error_Protocol _ ad) = (AlertLevel_Fatal, ad) -errorToAlert (Error_Protocol_Warning _ ad) = (AlertLevel_Warning, ad) +errorToAlert (Error_Protocol _ ad) = (AlertLevel_Fatal, ad) +errorToAlert (Error_Protocol_Warning _ ad) = (AlertLevel_Warning, ad) errorToAlert (Error_Packet_unexpected _ _) = (AlertLevel_Fatal, UnexpectedMessage) errorToAlert (Error_Packet_Parsing msg) - | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) - | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) - | otherwise = (AlertLevel_Fatal, DecodeError) -errorToAlert _ = (AlertLevel_Fatal, InternalError) + | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) + | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) + | otherwise = (AlertLevel_Fatal, DecodeError) +errorToAlert _ = (AlertLevel_Fatal, InternalError) -- | Return the message that a TLS endpoint can add to its local log for the -- specified library error. errorToAlertMessage :: TLSError -> String -errorToAlertMessage (Error_Protocol msg _) = msg +errorToAlertMessage (Error_Protocol msg _) = msg errorToAlertMessage (Error_Protocol_Warning msg _) = msg -errorToAlertMessage (Error_Packet_unexpected msg _) = msg -errorToAlertMessage (Error_Packet_Parsing msg) = msg -errorToAlertMessage e = show e +errorToAlertMessage (Error_Packet_unexpected msg _) = msg +errorToAlertMessage (Error_Packet_Parsing msg) = msg +errorToAlertMessage e = show e unexpected :: MonadIO m => String -> Maybe String -> m a -unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) +unexpected msg expected = + throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 - | otherwise = return $ Session Nothing + | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up. -handshakeTerminate :: Context -> IO () -handshakeTerminate ctx = do - session <- usingState_ ctx getSession - -- only callback the session established if we have a session - case session of - Session (Just sessionId) -> do - sessionData <- getSessionData ctx - let !sessionId' = B.copy sessionId - liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' (fromJust "session-data" sessionData) - _ -> return () +handshakeDone12 :: Context -> IO () +handshakeDone12 ctx = do -- forget most handshake data and reset bytes counters. - liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> - case mhshake of - Nothing -> return Nothing - Just hshake -> - return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) - { hstServerRandom = hstServerRandom hshake - , hstMasterSecret = hstMasterSecret hshake - , hstExtendedMasterSec = hstExtendedMasterSec hshake - , hstNegotiatedGroup = hstNegotiatedGroup hshake - } + 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 () -sendChangeCipherAndFinish :: Context - -> Role - -> IO () -sendChangeCipherAndFinish ctx role = do - sendPacket ctx ChangeCipherSpec - liftIO $ contextFlush ctx - cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role - sendPacket ctx (Handshake [Finished cf]) - writeIORef (ctxFinished ctx) $ Just cf - liftIO $ contextFlush ctx - -recvChangeCipherAndFinish :: Context -> IO () -recvChangeCipherAndFinish ctx = runRecvState ctx (RecvStateNext expectChangeCipher) - where expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish - expectChangeCipher p = unexpected (show p) (Just "change cipher") - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") +sendCCSandFinished + :: Context + -> Role + -> IO () +sendCCSandFinished ctx role = do + sendPacket12 ctx ChangeCipherSpec + contextFlush ctx + verifyData <- + usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role + sendPacket12 ctx (Handshake [Finished verifyData]) + usingState_ ctx $ setVerifyDataForSend verifyData + contextFlush ctx -data RecvState m = - RecvStateNext (Packet -> m (RecvState m)) +data RecvState m + = RecvStatePacket (Packet -> m (RecvState m)) -- CCS is not Handshake | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone recvPacketHandshake :: Context -> IO [Handshake] recvPacketHandshake ctx = do - pkts <- recvPacket ctx + pkts <- recvPacket12 ctx case pkts of Right (Handshake l) -> return l Right x@(AppData _) -> do @@ -164,93 +158,119 @@ established <- ctxEstablished ctx case established of EarlyDataNotAllowed n - | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1) - recvPacketHandshake ctx - _ -> unexpected (show x) (Just "handshake") - Right x -> unexpected (show x) (Just "handshake") - Left err -> throwCore err + | n > 0 -> do + setEstablished ctx $ EarlyDataNotAllowed (n - 1) + recvPacketHandshake ctx + _ -> unexpected (show x) (Just "handshake") + Right x -> unexpected (show x) (Just "handshake") + Left err -> throwCore err -- | process a list of handshakes message in the recv state machine. -onRecvStateHandshake :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO) -onRecvStateHandshake _ recvState [] = return recvState -onRecvStateHandshake _ (RecvStateNext f) hms = f (Handshake hms) -onRecvStateHandshake ctx (RecvStateHandshake f) (x:xs) = do +onRecvStateHandshake + :: Context -> RecvState IO -> [Handshake] -> 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 - processHandshake ctx x + when finished $ processHandshake12 ctx x onRecvStateHandshake ctx nstate xs -onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing +onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing +isFinished :: Handshake -> Bool +isFinished Finished{} = True +isFinished _ = False + runRecvState :: Context -> RecvState IO -> IO () -runRecvState _ RecvStateDone = return () -runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx -runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx +runRecvState _ RecvStateDone = return () +runRecvState ctx (RecvStatePacket f) = recvPacket12 ctx >>= either throwCore f >>= runRecvState ctx +runRecvState ctx iniState = + recvPacketHandshake ctx + >>= onRecvStateHandshake ctx iniState + >>= runRecvState ctx +runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO () +runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx + ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do complete <- liftIO $ isRecvComplete ctx unless complete $ - throwCore $ Error_Protocol "received incomplete message at key change" UnexpectedMessage + throwCore $ + Error_Protocol "received incomplete message at key change" UnexpectedMessage -processExtendedMasterSec :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool -processExtendedMasterSec ctx ver msgt exts - | ver < TLS10 = return False - | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" +processExtendedMainSecret + :: MonadIO m => Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool +processExtendedMainSecret ctx ver msgt exts + | ver < TLS10 = return False + | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False - | otherwise = - case extensionLookup extensionID_ExtendedMasterSecret exts >>= extensionDecode msgt of - Just ExtendedMasterSecret -> usingHState ctx (setExtendedMasterSec True) >> return True - Nothing | ems == RequireEMS -> throwCore $ Error_Protocol err HandshakeFailure - | otherwise -> return False - where ems = supportedExtendedMasterSec (ctxSupported ctx) - err = "peer does not support Extended Master Secret" + | 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 + where + ems = supportedExtendedMainSecret (ctxSupported ctx) + err = "peer does not support Extended Main Secret" getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion sni <- usingState_ ctx getClientSNI - mms <- usingHState ctx (gets hstMasterSecret) - !ems <- usingHState ctx getExtendedMasterSec - tx <- liftIO $ readMVar (ctxTxState ctx) + mms <- usingHState ctx $ gets hstMainSecret + ems <- usingHState ctx getExtendedMainSecret + cipher <- cipherID <$> usingHState ctx getPendingCipher alpn <- usingState_ ctx getNegotiatedProtocol - let !cipher = cipherID $ fromJust "cipher" $ stCipher tx - !compression = compressionID $ stCompression tx + let compression = 0 flags = [SessionEMS | ems] case mms of Nothing -> return Nothing - Just ms -> return $ Just SessionData - { sessionVersion = ver - , sessionCipher = cipher + Just ms -> + return $ + Just + SessionData + { sessionVersion = ver + , sessionCipher = cipher , sessionCompression = compression - , sessionClientSNI = sni - , sessionSecret = ms - , sessionGroup = Nothing - , sessionTicketInfo = Nothing - , sessionALPN = alpn + , sessionClientSNI = sni + , sessionSecret = ms + , sessionGroup = Nothing + , sessionTicketInfo = Nothing + , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 - , sessionFlags = flags + , sessionFlags = flags } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString -extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) - . find (\(ExtensionRaw eid _) -> eid == toFind) +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 -- types of keys match and that it does not include an algorithm that would -- not be safe. -storePrivInfo :: MonadIO m - => Context - -> CertificateChain - -> PrivKey - -> m PubKey +storePrivInfo + :: MonadIO m + => Context + -> CertificateChain + -> PrivKey + -> m PubKey storePrivInfo ctx cc privkey = do - let CertificateChain (c:_) = cc + let c = fromCC cc pubkey = certPubKey $ getCertificate c unless (isDigitalSignaturePair (pubkey, privkey)) $ - throwCore $ Error_Protocol "mismatched or unsupported private key pair" InternalError + throwCore $ + Error_Protocol "mismatched or unsupported private key pair" InternalError usingHState ctx $ setPublicPrivateKeys (pubkey, privkey) return pubkey + where + fromCC (CertificateChain (c : _)) = c + fromCC _ = error "fromCC" -- verify that the group selected by the peer is supported in the local -- configuration @@ -262,3 +282,31 @@ isSupportedGroup :: Context -> Group -> Bool isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx) + +ensureNullCompression :: MonadIO m => CompressionID -> m () +ensureNullCompression compression = + when (compression /= compressionID nullCompression) $ + throwCore $ + Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter + +expectFinished :: Context -> Handshake -> IO (RecvState IO) +expectFinished ctx (Finished verifyData) = do + processFinished ctx verifyData + return RecvStateDone +expectFinished _ p = unexpected (show p) (Just "Handshake Finished") + +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" + usingState_ ctx $ setVerifyDataForRecv verifyData + +processCertificate :: Context -> Role -> CertificateChain -> IO () +processCertificate _ ServerRole (CertificateChain []) = return () +processCertificate _ ClientRole (CertificateChain []) = + throwCore $ Error_Protocol "server certificate missing" HandshakeFailure +processCertificate ctx _ (CertificateChain (c : _)) = + usingHState ctx $ setPublicKey pubkey + where + pubkey = certPubKey $ getCertificate c diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -1,59 +1,55 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | --- Module : Network.TLS.Handshake.Common13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.Common13 - ( makeFinished - , checkFinished - , makeServerKeyShare - , makeClientKeyShare - , fromServerKeyShare - , makeCertVerify - , checkCertVerify - , makePSKBinder - , replacePSKBinder - , sendChangeCipherSpec13 - , handshakeTerminate13 - , makeCertRequest - , createTLS13TicketInfo - , ageToObfuscatedAge - , isAgeValid - , getAge - , checkFreshness - , getCurrentTimeFromBase - , getSessionData13 - , ensureNullCompression - , isHashSignatureValid13 - , safeNonNegative32 - , RecvHandshake13M - , runRecvHandshake13 - , recvHandshake13 - , recvHandshake13hash - , CipherChoice(..) - , makeCipherChoice - , initEarlySecret - , calculateEarlySecret - , calculateHandshakeSecret - , calculateApplicationSecret - , calculateResumptionSecret - , derivePSK - , checkKeyShareKeyLength - ) where +module Network.TLS.Handshake.Common13 ( + makeFinished, + checkFinished, + makeServerKeyShare, + makeClientKeyShare, + fromServerKeyShare, + makeCertVerify, + checkCertVerify, + makePSKBinder, + replacePSKBinder, + sendChangeCipherSpec13, + handshakeDone13, + makeCertRequest, + createTLS13TicketInfo, + ageToObfuscatedAge, + isAgeValid, + getAge, + checkFreshness, + getCurrentTimeFromBase, + getSessionData13, + isHashSignatureValid13, + safeNonNegative32, + RecvHandshake13M, + runRecvHandshake13, + recvHandshake13, + recvHandshake13hash, + CipherChoice (..), + makeCipherChoice, + initEarlySecret, + calculateEarlySecret, + calculateHandshakeSecret, + calculateApplicationSecret, + calculateResumptionSecret, + derivePSK, + checkKeyShareKeyLength, + setRTT, +) where import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.UnixTime -import Foreign.C.Types (CTime(..)) +import Foreign.C.Types (CTime (..)) import Network.TLS.Cipher -import Network.TLS.Compression import Network.TLS.Context.Internal import Network.TLS.Crypto import qualified Network.TLS.Crypto.IES as IES + import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname) import Network.TLS.Handshake.Common (unexpected) @@ -75,22 +71,24 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict -import Data.IORef (writeIORef) ---------------------------------------------------------------- makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13 makeFinished ctx usedHash baseKey = do - finished <- makeVerifyData usedHash baseKey <$> transcriptHash ctx - liftIO $ writeIORef (ctxFinished ctx) (Just finished) - pure $ Finished13 finished + verifyData <- makeVerifyData usedHash baseKey <$> transcriptHash ctx + liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData + pure $ Finished13 verifyData -checkFinished :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m () +checkFinished + :: MonadIO m => Context -> Hash -> ByteString -> ByteString -> ByteString -> m () checkFinished ctx usedHash baseKey hashValue verifyData = do let verifyData' = makeVerifyData usedHash baseKey hashValue - when (B.length verifyData /= B.length verifyData') $ throwCore $ Error_Protocol "broken Finished" DecodeError + when (B.length verifyData /= B.length verifyData') $ + throwCore $ + Error_Protocol "broken Finished" DecodeError unless (verifyData' == verifyData) $ decryptError "cannot verify finished" - liftIO $ writeIORef (ctxPeerFinished ctx) (Just verifyData) + liftIO $ usingState_ ctx $ setVerifyDataForRecv verifyData makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString makeVerifyData usedHash baseKey = hmac usedHash finishedKey @@ -102,15 +100,15 @@ makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of - Left e -> throwCore $ Error_Protocol (show e) IllegalParameter - Right cpub -> do - ecdhePair <- generateECDHEShared ctx cpub - case ecdhePair of - Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter - Just (spub, share) -> - let wspub = IES.encodeGroupPublic spub - serverKeyShare = KeyShareEntry grp wspub - in return (BA.convert share, serverKeyShare) + Left e -> throwCore $ Error_Protocol (show e) IllegalParameter + Right cpub -> do + ecdhePair <- generateECDHEShared ctx cpub + case ecdhePair of + Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter + Just (spub, share) -> + let wspub = IES.encodeGroupPublic spub + serverKeyShare = KeyShareEntry grp wspub + in return (BA.convert share, serverKeyShare) where ecpub = IES.decodeGroupPublic grp wcpub msgInvalidPublic = "invalid client " ++ show grp ++ " public key" @@ -124,10 +122,12 @@ fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString fromServerKeyShare (KeyShareEntry grp wspub) cpri = 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 + 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 where espub = IES.decodeGroupPublic grp wspub @@ -139,24 +139,39 @@ clientContextString :: ByteString clientContextString = "TLS 1.3, client CertificateVerify" -makeCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13 +makeCertVerify + :: MonadIO m + => Context + -> PubKey + -> HashAndSignatureAlgorithm + -> ByteString + -> m Handshake13 makeCertVerify ctx pub hs hashValue = do - cc <- liftIO $ usingState_ ctx isClientContext - let ctxStr | cc == ClientRole = clientContextString - | otherwise = serverContextString + role <- liftIO $ usingState_ ctx getRole + let ctxStr + | role == ClientRole = clientContextString + | otherwise = serverContextString target = makeTarget ctxStr hashValue CertVerify13 hs <$> sign ctx pub hs target -checkCertVerify :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool +checkCertVerify + :: MonadIO m + => Context + -> PubKey + -> HashAndSignatureAlgorithm + -> Signature + -> ByteString + -> m Bool checkCertVerify ctx pub hs signature hashValue | pub `signatureCompatible13` hs = liftIO $ do - cc <- usingState_ ctx isClientContext - let ctxStr | cc == ClientRole = serverContextString -- opposite context - | otherwise = clientContextString + role <- usingState_ ctx getRole + let ctxStr + | role == ClientRole = serverContextString -- opposite context + | otherwise = clientContextString target = makeTarget ctxStr hashValue - sigParams = signatureParams pub (Just hs) + sigParams = signatureParams pub hs checkHashSignatureValid13 hs - checkSupportedHashSignature ctx (Just hs) + checkSupportedHashSignature ctx hs verifyPublic ctx sigParams target signature | otherwise = return False @@ -167,20 +182,32 @@ putWord8 0 putBytes hashValue -sign :: MonadIO m => Context -> PubKey -> HashAndSignatureAlgorithm -> ByteString -> m Signature +sign + :: MonadIO m + => Context + -> PubKey + -> HashAndSignatureAlgorithm + -> ByteString + -> m Signature sign ctx pub hs target = liftIO $ do - cc <- usingState_ ctx isClientContext - let sigParams = signatureParams pub (Just hs) - signPrivate ctx cc sigParams target + role <- usingState_ ctx getRole + let sigParams = signatureParams pub hs + signPrivate ctx role sigParams target ---------------------------------------------------------------- -makePSKBinder :: Context -> BaseSecret EarlySecret -> Hash -> Int -> Maybe ByteString -> IO ByteString +makePSKBinder + :: Context + -> 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 + 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 @@ -194,42 +221,43 @@ replacePSKBinder pskz binder = identities `B.append` binders where bindersSize = B.length binder + 3 - identities = B.take (B.length pskz - bindersSize) pskz - binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder + identities = B.take (B.length pskz - bindersSize) pskz + binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder ---------------------------------------------------------------- sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b () sendChangeCipherSpec13 ctx = do sent <- usingHState ctx $ do - b <- getCCS13Sent - unless b $ setCCS13Sent True - return b + b <- getCCS13Sent + unless b $ setCCS13Sent True + return b unless sent $ loadPacket13 ctx ChangeCipherSpec13 ---------------------------------------------------------------- --- | TLS13 handshake wrap up & clean up. Contrary to @handshakeTerminate@, this +-- | 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. -handshakeTerminate13 :: Context -> IO () -handshakeTerminate13 ctx = do +handshakeDone13 :: Context -> IO () +handshakeDone13 ctx = do -- forget most handshake data - liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> - case mhshake of - Nothing -> return Nothing - Just hshake -> - return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) - { hstServerRandom = hstServerRandom hshake - , hstMasterSecret = hstMasterSecret hshake - , hstNegotiatedGroup = hstNegotiatedGroup hshake - , hstHandshakeDigest = hstHandshakeDigest hshake - , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake - , hstTLS13RTT0Status = hstTLS13RTT0Status hshake - , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake - } + 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 @@ -241,18 +269,23 @@ makeCertRequest :: ServerParams -> Context -> CertReqContext -> Handshake13 makeCertRequest sparams ctx certReqCtx = - let sigAlgs = extensionEncode $ SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx + let sigAlgs = + extensionEncode $ + SignatureAlgorithms $ + supportedHashSignatures $ + ctxSupported ctx caDns = map extractCAname $ serverCACertificates sparams caDnsEncoded = extensionEncode $ CertificateAuthorities caDns caExtension | null caDns = [] - | otherwise = [ExtensionRaw extensionID_CertificateAuthorities caDnsEncoded] - crexts = ExtensionRaw extensionID_SignatureAlgorithms sigAlgs : caExtension + | otherwise = [ExtensionRaw EID_CertificateAuthorities caDnsEncoded] + crexts = ExtensionRaw EID_SignatureAlgorithms sigAlgs : caExtension in CertRequest13 certReqCtx crexts ---------------------------------------------------------------- -createTLS13TicketInfo :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo +createTLS13TicketInfo + :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo createTLS13TicketInfo life ecw mrtt = do -- Left: serverSendTime -- Right: clientReceiveTime @@ -260,43 +293,50 @@ add <- case ecw of Left ctx -> B.foldl' (*+) 0 <$> getStateRNG ctx 4 Right ad -> return ad - return $ TLS13TicketInfo life add bTime mrtt + return $ + TLS13TicketInfo + { lifetime = life + , ageAdd = add + , txrxTime = bTime + , estimatedRTT = mrtt + } where x *+ y = x * 256 + fromIntegral y ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second -ageToObfuscatedAge age tinfo = obfage +ageToObfuscatedAge age TLS13TicketInfo{..} = obfage where - !obfage = age + ageAdd tinfo + obfage = age + ageAdd obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second -obfuscatedAgeToAge obfage tinfo = age +obfuscatedAgeToAge obfage TLS13TicketInfo{..} = age where - !age = obfage - ageAdd tinfo + age = obfage - ageAdd isAgeValid :: Second -> TLS13TicketInfo -> Bool -isAgeValid age tinfo = age <= lifetime tinfo * 1000 +isAgeValid age TLS13TicketInfo{..} = age <= lifetime * 1000 getAge :: TLS13TicketInfo -> IO Second -getAge tinfo = do - let clientReceiveTime = txrxTime tinfo +getAge TLS13TicketInfo{..} = do + let clientReceiveTime = txrxTime clientSendTime <- getCurrentTimeFromBase - return $! fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds + return $ fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds checkFreshness :: TLS13TicketInfo -> Second -> IO Bool -checkFreshness tinfo obfAge = do +checkFreshness tinfo@TLS13TicketInfo{..} obfAge = do serverReceiveTime <- getCurrentTimeFromBase - let freshness = if expectedArrivalTime > serverReceiveTime - then expectedArrivalTime - serverReceiveTime - else serverReceiveTime - expectedArrivalTime + let freshness = + if expectedArrivalTime > serverReceiveTime + then expectedArrivalTime - serverReceiveTime + else serverReceiveTime - expectedArrivalTime -- Some implementations round age up to second. -- We take max of 2000 and rtt in the case where rtt is too small. let tolerance = max 2000 rtt isFresh = freshness < tolerance return $ isAlive && isFresh where - serverSendTime = txrxTime tinfo - Just rtt = estimatedRTT tinfo + serverSendTime = txrxTime + rtt = fromJust estimatedRTT age = obfuscatedAgeToAge obfAge tinfo expectedArrivalTime = serverSendTime + rtt + fromIntegral age isAlive = isAgeValid age tinfo @@ -309,60 +349,61 @@ fromIntegral ((s - base) * 1000) + fromIntegral (us `div` 1000) where base = 1483228800 - -- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT" +-- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT" + ---------------------------------------------------------------- -getSessionData13 :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData +getSessionData13 + :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData getSessionData13 ctx usedCipher tinfo maxSize psk = do - ver <- usingState_ ctx getVersion + ver <- usingState_ ctx getVersion malpn <- usingState_ ctx getNegotiatedProtocol - sni <- usingState_ ctx getClientSNI - mgrp <- usingHState ctx getNegotiatedGroup - return SessionData { - sessionVersion = ver - , sessionCipher = cipherID usedCipher - , sessionCompression = 0 - , sessionClientSNI = sni - , sessionSecret = psk - , sessionGroup = mgrp - , sessionTicketInfo = Just tinfo - , sessionALPN = malpn - , sessionMaxEarlyDataSize = maxSize - , sessionFlags = [] - } + sni <- usingState_ ctx getClientSNI + mgrp <- usingHState ctx getSupportedGroup + return + SessionData + { sessionVersion = ver + , sessionCipher = cipherID usedCipher + , sessionCompression = 0 + , sessionClientSNI = sni + , sessionSecret = psk + , sessionGroup = mgrp + , sessionTicketInfo = Just tinfo + , sessionALPN = malpn + , sessionMaxEarlyDataSize = maxSize + , sessionFlags = [] + } ---------------------------------------------------------------- -ensureNullCompression :: MonadIO m => CompressionID -> m () -ensureNullCompression compression = - when (compression /= compressionID nullCompression) $ - throwCore $ Error_Protocol "compression is not allowed in TLS 1.3" IllegalParameter - -- Word32 is used in TLS 1.3 protocol. -- Int is used for API for Haskell TLS because it is natural. -- If Int is 64 bits, users can specify bigger number than Word32. -- If Int is 32 bits, 2^31 or larger may be converted into minus numbers. safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a safeNonNegative32 x - | x <= 0 = 0 - | finiteBitSize x <= 32 = x - | otherwise = x `min` fromIntegral (maxBound :: Word32) + | x <= 0 = 0 + | finiteBitSize x <= 32 = x + | otherwise = x `min` fromIntegral (maxBound :: Word32) + ---------------------------------------------------------------- newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a) deriving (Functor, Applicative, Monad, MonadIO) -recvHandshake13 :: MonadIO m - => Context - -> (Handshake13 -> RecvHandshake13M m a) - -> RecvHandshake13M m a +recvHandshake13 + :: MonadIO m + => Context + -> (Handshake13 -> RecvHandshake13M m a) + -> RecvHandshake13M m a recvHandshake13 ctx f = getHandshake13 ctx >>= f -recvHandshake13hash :: MonadIO m - => Context - -> (ByteString -> Handshake13 -> RecvHandshake13M m a) - -> RecvHandshake13M m a +recvHandshake13hash + :: MonadIO m + => Context + -> (ByteString -> Handshake13 -> RecvHandshake13M m a) + -> RecvHandshake13M m a recvHandshake13hash ctx f = do d <- transcriptHash ctx getHandshake13 ctx >>= f d @@ -371,18 +412,18 @@ getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of - (h:hs) -> found h hs - [] -> recvLoop + (h : hs) -> found h hs + [] -> recvLoop where found h hs = liftIO (processHandshake13 ctx h) >> put hs >> return h 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 x -> unexpected (show x) (Just "handshake 13") - Left err -> throwCore err + Right (Handshake13 []) -> error "invalid recvPacket13 result" + Right (Handshake13 (h : hs)) -> found h hs + Right ChangeCipherSpec13 -> recvLoop + Right x -> unexpected (show x) (Just "handshake 13") + Left err -> throwCore err runRecvHandshake13 :: MonadIO m => RecvHandshake13M m a -> m a runRecvHandshake13 (RecvHandshake13M f) = do @@ -402,46 +443,38 @@ isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool isHashSignatureValid13 (HashIntrinsic, s) = - s `elem` [ SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureEd25519 - , SignatureEd448 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] + s + `elem` [ SignatureRSApssRSAeSHA256 + , SignatureRSApssRSAeSHA384 + , SignatureRSApssRSAeSHA512 + , SignatureEd25519 + , SignatureEd448 + , SignatureRSApsspssSHA256 + , SignatureRSApsspssSHA384 + , SignatureRSApsspssSHA512 + ] isHashSignatureValid13 (h, SignatureECDSA) = - h `elem` [ HashSHA256, HashSHA384, HashSHA512 ] + h `elem` [HashSHA256, HashSHA384, HashSHA512] isHashSignatureValid13 _ = False -data CipherChoice = CipherChoice { - cVersion :: Version - , cCipher :: Cipher - , cHash :: Hash - , cZero :: !ByteString - } - -makeCipherChoice :: Version -> Cipher -> CipherChoice -makeCipherChoice ver cipher = CipherChoice ver cipher h zero - where - h = cipherHash cipher - zero = B.replicate (hashDigestSize h) 0 - ---------------------------------------------------------------- -calculateEarlySecret :: Context -> CipherChoice - -> Either ByteString (BaseSecret EarlySecret) - -> Bool -> IO (SecretPair EarlySecret) +calculateEarlySecret + :: 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 + hCh <- + if initialized + then transcriptHash ctx + else do + hmsgs <- usingHState ctx getHandshakeMessages + return $ hash usedHash $ B.concat hmsgs let earlySecret = case maux of - Right (BaseSecret sec) -> sec - Left psk -> hkdfExtract usedHash zero psk + Right (BaseSecret sec) -> sec + Left psk -> hkdfExtract usedHash zero psk clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets @@ -456,35 +489,55 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice - zeroOrPSK = case mpsk of - Just psk -> psk - Nothing -> zero + zeroOrPSK = fromMaybe zero mpsk -calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret -> ByteString - -> IO (SecretTriple HandshakeSecret) +calculateHandshakeSecret + :: Context + -> CipherChoice + -> BaseSecret EarlySecret + -> ByteString + -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do - hChSh <- transcriptHash ctx - let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) ecdhe - let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh - serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh - let shts = ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret - chts = ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret - logKey ctx shts - logKey ctx chts - return $ SecretTriple (BaseSecret handshakeSecret) chts shts + hChSh <- transcriptHash ctx + let handshakeSecret = + hkdfExtract + usedHash + (deriveSecret usedHash sec "derived" (hash usedHash "")) + ecdhe + let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh + serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh + let shts = + ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret + chts = + ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret + logKey ctx shts + logKey ctx chts + return $ SecretTriple (BaseSecret handshakeSecret) chts shts where usedHash = cHash choice -calculateApplicationSecret :: Context -> CipherChoice -> BaseSecret HandshakeSecret -> ByteString - -> IO (SecretTriple ApplicationSecret) +calculateApplicationSecret + :: Context + -> CipherChoice + -> BaseSecret HandshakeSecret + -> ByteString + -> IO (SecretTriple ApplicationSecret) calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do - let applicationSecret = hkdfExtract usedHash (deriveSecret usedHash sec "derived" (hash usedHash "")) zero + let applicationSecret = + hkdfExtract + usedHash + (deriveSecret usedHash sec "derived" (hash usedHash "")) + zero let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf - exporterMasterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf - usingState_ ctx $ setExporterMasterSecret exporterMasterSecret - let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret - let cts0 = ClientTrafficSecret clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret + exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf + usingState_ ctx $ setExporterSecret exporterSecret + let sts0 = + ServerTrafficSecret serverApplicationSecret0 + :: ServerTrafficSecret ApplicationSecret + let cts0 = + ClientTrafficSecret clientApplicationSecret0 + :: ClientTrafficSecret ApplicationSecret logKey ctx sts0 logKey ctx cts0 return $ SecretTriple (BaseSecret applicationSecret) cts0 sts0 @@ -492,16 +545,20 @@ usedHash = cHash choice zero = cZero choice -calculateResumptionSecret :: Context -> CipherChoice -> BaseSecret ApplicationSecret - -> IO (BaseSecret ResumptionSecret) +calculateResumptionSecret + :: Context + -> CipherChoice + -> BaseSecret ApplicationSecret + -> IO (BaseSecret ResumptionSecret) calculateResumptionSecret ctx choice (BaseSecret sec) = do hChCf <- transcriptHash ctx - let resumptionMasterSecret = deriveSecret usedHash sec "res master" hChCf - return $ BaseSecret resumptionMasterSecret + let resumptionSecret = deriveSecret usedHash sec "res master" hChCf + return $ BaseSecret resumptionSecret where usedHash = cHash choice -derivePSK :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString +derivePSK + :: CipherChoice -> BaseSecret ResumptionSecret -> ByteString -> ByteString derivePSK choice (BaseSecret sec) nonce = hkdfExpandLabel usedHash sec "resumption" nonce hashSize where @@ -517,13 +574,21 @@ 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 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" + +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} diff --git a/Network/TLS/Handshake/Control.hs b/Network/TLS/Handshake/Control.hs --- a/Network/TLS/Handshake/Control.hs +++ b/Network/TLS/Handshake/Control.hs @@ -1,18 +1,11 @@ --- | --- Module : Network.TLS.Handshake.Control --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- module Network.TLS.Handshake.Control ( - ClientState(..) - , ServerState(..) - , EarlySecretInfo(..) - , HandshakeSecretInfo(..) - , ApplicationSecretInfo(..) - , NegotiatedProtocol - ) where + ClientState (..), + ServerState (..), + EarlySecretInfo (..), + HandshakeSecretInfo (..), + ApplicationSecretInfo (..), + NegotiatedProtocol, +) where import Network.TLS.Cipher import Network.TLS.Imports @@ -27,23 +20,24 @@ -- | Handshake information generated for traffic at 0-RTT level. data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret) - deriving Show + deriving (Show) -- | Handshake information generated for traffic at handshake level. -data HandshakeSecretInfo = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret) - deriving Show +data HandshakeSecretInfo + = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret) + deriving (Show) -- | Handshake information generated for traffic at application level. newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret) - deriving Show + deriving (Show) ---------------------------------------------------------------- -data ClientState = - SendClientHello (Maybe EarlySecretInfo) - | RecvServerHello HandshakeSecretInfo - | SendClientFinished [ExtensionRaw] ApplicationSecretInfo +data ClientState + = SendClientHello (Maybe EarlySecretInfo) + | RecvServerHello HandshakeSecretInfo + | SendClientFinished [ExtensionRaw] ApplicationSecretInfo -data ServerState = - SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo - | SendServerFinished ApplicationSecretInfo +data ServerState + = SendServerHello [ExtensionRaw] (Maybe EarlySecretInfo) HandshakeSecretInfo + | SendServerFinished ApplicationSecretInfo diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -1,42 +1,35 @@ {-# LANGUAGE FlexibleInstances #-} --- | --- Module : Network.TLS.Handshake.Key --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- functions for RSA operations --- -module Network.TLS.Handshake.Key - ( encryptRSA - , signPrivate - , decryptRSA - , verifyPublic - , generateDHE - , generateECDHE - , generateECDHEShared - , generateFFDHE - , generateFFDHEShared - , versionCompatible - , isDigitalSignaturePair - , checkDigitalSignatureKey - , getLocalPublicKey - , satisfiesEcPredicate - , logKey - ) where +-- | Functions for RSA operations +module Network.TLS.Handshake.Key ( + encryptRSA, + signPrivate, + decryptRSA, + verifyPublic, + generateDHE, + generateECDHE, + generateECDHEShared, + generateFFDHE, + generateFFDHEShared, + versionCompatible, + isDigitalSignaturePair, + checkDigitalSignatureKey, + getLocalPublicKey, + satisfiesEcPredicate, + logKey, +) where + import Control.Monad.State.Strict import qualified Data.ByteString as B -import Network.TLS.Handshake.State -import Network.TLS.State (withRNG, getVersion) -import Network.TLS.Crypto -import Network.TLS.Types import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Handshake.State import Network.TLS.Imports +import Network.TLS.State (withRNG) import Network.TLS.Struct +import Network.TLS.Types import Network.TLS.X509 {- if the RSA encryption fails we just return an empty bytestring, and let the protocol @@ -48,7 +41,7 @@ usingState_ ctx $ do v <- withRNG $ kxEncrypt publicKey content case v of - Left err -> error ("rsa encrypt failed: " ++ show err) + Left err -> error ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString @@ -57,18 +50,18 @@ usingState_ ctx $ do r <- withRNG $ kxSign privateKey publicKey params content case r of - Left err -> error ("sign failed: " ++ show err) + Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do - ver <- getVersion - let cipher = if ver < TLS10 then econtent else B.drop 2 econtent + let cipher = B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher -verifyPublic :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool +verifyPublic + :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool verifyPublic ctx params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey params econtent sign @@ -79,30 +72,34 @@ generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic) generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) +generateECDHEShared + :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp -generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) +generateFFDHEShared + :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub +{- FOURMOLU_DISABLE -} isDigitalSignatureKey :: PubKey -> Bool -isDigitalSignatureKey (PubKeyRSA _) = True -isDigitalSignatureKey (PubKeyDSA _) = True -isDigitalSignatureKey (PubKeyEC _) = True -isDigitalSignatureKey (PubKeyEd25519 _) = True -isDigitalSignatureKey (PubKeyEd448 _) = True -isDigitalSignatureKey _ = False +isDigitalSignatureKey (PubKeyRSA _) = True +isDigitalSignatureKey (PubKeyDSA _) = True +isDigitalSignatureKey (PubKeyEC _) = True +isDigitalSignatureKey (PubKeyEd25519 _) = True +isDigitalSignatureKey (PubKeyEd448 _) = True +isDigitalSignatureKey _ = False versionCompatible :: PubKey -> Version -> Bool -versionCompatible (PubKeyRSA _) _ = True -versionCompatible (PubKeyDSA _) v = v <= TLS12 -versionCompatible (PubKeyEC _) v = v >= TLS10 -versionCompatible (PubKeyEd25519 _) v = v >= TLS12 -versionCompatible (PubKeyEd448 _) v = v >= TLS12 -versionCompatible _ _ = False +versionCompatible (PubKeyRSA _) _ = True +versionCompatible (PubKeyDSA _) v = v <= TLS12 +versionCompatible (PubKeyEC _) v = v >= TLS10 +versionCompatible (PubKeyEd25519 _) v = v >= TLS12 +versionCompatible (PubKeyEd448 _) v = v >= TLS12 +versionCompatible _ _ = False +{- FOURMOLU_ENABLE -} -- | Test whether the argument is a public key supported for signature at the -- specified TLS version. This also accepts a key for RSA encryption. This @@ -111,9 +108,13 @@ checkDigitalSignatureKey :: MonadIO m => Version -> PubKey -> m () checkDigitalSignatureKey usedVersion key = do unless (isDigitalSignatureKey key) $ - throwCore $ Error_Protocol "unsupported remote public key type" HandshakeFailure + throwCore $ + Error_Protocol "unsupported remote public key type" HandshakeFailure unless (key `versionCompatible` usedVersion) $ - throwCore $ Error_Protocol (show usedVersion ++ " has no support for " ++ pubkeyType key) IllegalParameter + throwCore $ + Error_Protocol + (show usedVersion ++ " has no support for " ++ pubkeyType key) + IllegalParameter -- | Test whether the argument is matching key pair supported for signature. -- This also accepts material for RSA encryption. This test is performed by @@ -121,12 +122,12 @@ isDigitalSignaturePair :: (PubKey, PrivKey) -> Bool isDigitalSignaturePair keyPair = case keyPair of - (PubKeyRSA _, PrivKeyRSA _) -> True - (PubKeyDSA _, PrivKeyDSA _) -> True - (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k - (PubKeyEd25519 _, PrivKeyEd25519 _) -> True - (PubKeyEd448 _, PrivKeyEd448 _) -> True - _ -> False + (PubKeyRSA _, PrivKeyRSA _) -> True + (PubKeyDSA _, PrivKeyDSA _) -> True + (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k + (PubKeyEd25519 _, PrivKeyEd25519 _) -> True + (PubKeyEd448 _, PrivKeyEd448 _) -> True + _ -> False getLocalPublicKey :: MonadIO m => Context -> m PubKey getLocalPublicKey ctx = @@ -138,15 +139,15 @@ satisfiesEcPredicate :: (Group -> Bool) -> PubKey -> Bool satisfiesEcPredicate p (PubKeyEC ecPub) = maybe False p $ findEllipticCurveGroup ecPub -satisfiesEcPredicate _ _ = True +satisfiesEcPredicate _ _ = True ---------------------------------------------------------------- class LogLabel a where labelAndKey :: a -> (String, ByteString) -instance LogLabel MasterSecret where - labelAndKey (MasterSecret key) = ("CLIENT_RANDOM", key) +instance LogLabel MainSecret where + labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key) instance LogLabel (ClientTrafficSecret EarlySecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_EARLY_TRAFFIC_SECRET", key) @@ -169,10 +170,10 @@ logKey ctx logkey = do mhst <- getHState ctx case mhst of - Nothing -> return () - Just hst -> do - let cr = unClientRandom $ hstClientRandom hst - (label,key) = labelAndKey logkey - ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key + Nothing -> return () + Just hst -> do + let cr = unClientRandom $ hstClientRandom hst + (label, key) = labelAndKey logkey + ctxKeyLogger ctx $ label ++ " " ++ dump cr ++ " " ++ dump key where dump = init . tail . showBytesHex diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -1,146 +1,35 @@ -- | --- Module : Network.TLS.Handshake.Process --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -- process handshake message received --- -module Network.TLS.Handshake.Process - ( processHandshake - , processHandshake13 - , startHandshake - ) where +module Network.TLS.Handshake.Process ( + processHandshake12, + processHandshake13, + startHandshake, +) where +import Control.Concurrent.MVar + import Network.TLS.Context.Internal -import Network.TLS.Crypto -import Network.TLS.ErrT -import Network.TLS.Extension -import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random -import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports -import Network.TLS.Packet -import Network.TLS.Parameters import Network.TLS.Sending -import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 -import Network.TLS.Types (Role(..), invertRole, MasterSecret(..)) -import Network.TLS.Util -import Control.Concurrent.MVar -import Control.Monad.IO.Class (liftIO) -import Control.Monad.State.Strict (gets) -import Data.X509 (CertificateChain(..), Certificate(..), getCertificate) -import Data.IORef (writeIORef) - -processHandshake :: Context -> Handshake -> IO () -processHandshake ctx hs = do - role <- usingState_ ctx isClientContext - case hs of - ClientHello cver ran _ cids _ ex _ -> when (role == ServerRole) $ do - mapM_ (usingState_ ctx . processClientExtension) ex - -- RFC 5746: secure renegotiation - -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} - when (secureRenegotiation && (0xff `elem` cids)) $ - usingState_ ctx $ setSecureRenegotiation True - hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx cver ran - Certificates certs -> processCertificates role certs - Finished fdata -> processClientFinished ctx fdata - _ -> return () +processHandshake12 :: Context -> Handshake -> IO () +processHandshake12 ctx hs = do when (isHRR hs) $ usingHState ctx wrapAsMessageHash13 - void $ updateHandshake ctx ServerRole hs - case hs of - ClientKeyXchg content -> when (role == ServerRole) $ - processClientKeyXchg ctx content - _ -> return () - where secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx - -- RFC5746: secure renegotiation - -- the renegotiation_info extension: 0xff01 - processClientExtension (ExtensionRaw 0xff01 content) | secureRenegotiation = do - v <- getVerifiedData ClientRole - let bs = extensionEncode (SecureRenegotiation v Nothing) - unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("client verified data not matching: " ++ show v ++ ":" ++ show content) HandshakeFailure - - setSecureRenegotiation True - -- unknown extensions - processClientExtension _ = return () - - processCertificates :: Role -> CertificateChain -> IO () - processCertificates ServerRole (CertificateChain []) = return () - processCertificates ClientRole (CertificateChain []) = - throwCore $ Error_Protocol "server certificate missing" HandshakeFailure - processCertificates _ (CertificateChain (c:_)) = - usingHState ctx $ setPublicKey pubkey - where pubkey = certPubKey $ getCertificate c - - isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand - isHRR _ = False + void $ updateHandshake12 ctx hs + where + isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand + isHRR _ = False processHandshake13 :: Context -> Handshake13 -> IO () processHandshake13 ctx = void . updateHandshake13 ctx --- process the client key exchange message. the protocol expects the initial --- client version received in ClientHello, not the negotiated version. --- in case the version mismatch, generate a random master secret -processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO () -processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do - (rver, role, random) <- usingState_ ctx $ do - (,,) <$> getVersion <*> isClientContext <*> genRandom 48 - ePremaster <- decryptRSA ctx encryptedPremaster - masterSecret <- usingHState ctx $ do - expectedVer <- gets hstClientVersion - case ePremaster of - Left _ -> setMasterSecretFromPre rver role random - Right premaster -> case decodePreMasterSecret premaster of - Left _ -> setMasterSecretFromPre rver role random - Right (ver, _) - | ver /= expectedVer -> setMasterSecretFromPre rver role random - | otherwise -> setMasterSecretFromPre rver role premaster - liftIO $ logKey ctx (MasterSecret masterSecret) - -processClientKeyXchg ctx (CKX_DH clientDHValue) = do - rver <- usingState_ ctx getVersion - role <- usingState_ ctx isClientContext - - serverParams <- usingHState ctx getServerDHParams - let params = serverDHParamsToParams serverParams - unless (dhValid params $ dhUnwrapPublic clientDHValue) $ - throwCore $ Error_Protocol "invalid client public key" IllegalParameter - - dhpriv <- usingHState ctx getDHPrivate - let premaster = dhGetShared params dhpriv clientDHValue - masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster - liftIO $ logKey ctx (MasterSecret masterSecret) - -processClientKeyXchg ctx (CKX_ECDH bytes) = do - ServerECDHParams grp _ <- usingHState ctx getServerECDHParams - case decodeGroupPublic grp bytes of - Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter - Right clipub -> do - srvpri <- usingHState ctx getGroupPrivate - case groupGetShared clipub srvpri of - Just premaster -> do - rver <- usingState_ ctx getVersion - role <- usingState_ ctx isClientContext - masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster - liftIO $ logKey ctx (MasterSecret masterSecret) - Nothing -> throwCore $ Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter - -processClientFinished :: Context -> FinishedData -> IO () -processClientFinished ctx fdata = do - (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion - expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc - when (expected /= fdata) $ decryptError "cannot verify finished" - writeIORef (ctxPeerFinished ctx) $ Just fdata - -- 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 liftIO $ void $ swapMVar (ctxHandshake ctx) hs + in void $ swapMVar (ctxHandshakeState ctx) hs diff --git a/Network/TLS/Handshake/Random.hs b/Network/TLS/Handshake/Random.hs --- a/Network/TLS/Handshake/Random.hs +++ b/Network/TLS/Handshake/Random.hs @@ -1,18 +1,12 @@ {-# LANGUAGE PatternGuards #-} --- | --- Module : Network.TLS.Handshake.Random --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- + module Network.TLS.Handshake.Random ( - serverRandom - , clientRandom - , hrrRandom - , isHelloRetryRequest - , isDowngraded - ) where + serverRandom, + clientRandom, + hrrRandom, + isHelloRetryRequest, + isDowngraded, +) where import qualified Data.ByteString as B import Network.TLS.Context.Internal @@ -28,15 +22,15 @@ -- consequence of our debug API allowing this). serverRandom :: Context -> Version -> [Version] -> IO ServerRandom serverRandom ctx chosenVer suppVers - | TLS13 `elem` suppVers = case chosenVer of - TLS13 -> ServerRandom <$> getStateRNG ctx 32 - TLS12 -> ServerRandom <$> genServRand suffix12 - _ -> ServerRandom <$> genServRand suffix11 - | TLS12 `elem` suppVers = case chosenVer of - TLS13 -> ServerRandom <$> getStateRNG ctx 32 - TLS12 -> ServerRandom <$> getStateRNG ctx 32 - _ -> ServerRandom <$> genServRand suffix11 - | otherwise = ServerRandom <$> getStateRNG ctx 32 + | TLS13 `elem` suppVers = case chosenVer of + TLS13 -> ServerRandom <$> getStateRNG ctx 32 + TLS12 -> ServerRandom <$> genServRand suffix12 + _ -> ServerRandom <$> genServRand suffix11 + | TLS12 `elem` suppVers = case chosenVer of + TLS13 -> ServerRandom <$> getStateRNG ctx 32 + TLS12 -> ServerRandom <$> getStateRNG ctx 32 + _ -> ServerRandom <$> genServRand suffix11 + | otherwise = ServerRandom <$> getStateRNG ctx 32 where genServRand suff = do pref <- getStateRNG ctx 24 @@ -46,12 +40,14 @@ -- other reason than the versions supported by the client). isDowngraded :: Version -> [Version] -> ServerRandom -> Bool isDowngraded ver suppVers (ServerRandom sr) - | ver <= TLS12 - , TLS13 `elem` suppVers = suffix12 `B.isSuffixOf` sr - || suffix11 `B.isSuffixOf` sr - | ver <= TLS11 - , TLS12 `elem` suppVers = suffix11 `B.isSuffixOf` sr - | otherwise = False + | ver <= TLS12 + , TLS13 `elem` suppVers = + suffix12 `B.isSuffixOf` sr + || suffix11 `B.isSuffixOf` sr + | ver <= TLS11 + , TLS12 `elem` suppVers = + suffix11 `B.isSuffixOf` sr + | otherwise = False suffix12 :: B.ByteString suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01] @@ -63,12 +59,42 @@ 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 - ] +hrrRandom = + ServerRandom $ + B.pack + [ 0xCF + , 0x21 + , 0xAD + , 0x74 + , 0xE5 + , 0x9A + , 0x61 + , 0x11 + , 0xBE + , 0x1D + , 0x8C + , 0x02 + , 0x1E + , 0x65 + , 0xB8 + , 0x91 + , 0xC2 + , 0xA2 + , 0x11 + , 0x16 + , 0x7A + , 0xBB + , 0x8C + , 0x5E + , 0x07 + , 0x9E + , 0x09 + , 0xE2 + , 0xC8 + , 0xA8 + , 0x33 + , 0x9C + ] isHelloRetryRequest :: ServerRandom -> Bool isHelloRetryRequest = (== hrrRandom) diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -1,1214 +1,91 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Server --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.Server - ( handshakeServer - , handshakeServerWith - , requestCertificateServer - , postHandshakeAuthServerWith - ) where - -import Network.TLS.Parameters -import Network.TLS.Imports -import Network.TLS.Context.Internal -import Network.TLS.Session -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.Cipher -import Network.TLS.Compression -import Network.TLS.Credentials -import Network.TLS.Crypto -import Network.TLS.Extension -import Network.TLS.Util (bytesEq, catchException, fromJust) -import Network.TLS.IO -import Network.TLS.Types -import Network.TLS.State -import Network.TLS.Handshake.Control -import Network.TLS.Handshake.State -import Network.TLS.Handshake.Process -import Network.TLS.Handshake.Key -import Network.TLS.Handshake.Random -import Network.TLS.Measurement -import qualified Data.ByteString as B -import Data.X509 (ExtKeyUsageFlag(..)) - -import Control.Monad.State.Strict -import Control.Exception (bracket) - -import Network.TLS.Handshake.Signature -import Network.TLS.Handshake.Common -import Network.TLS.Handshake.Certificate -import Network.TLS.X509 -import Network.TLS.Handshake.State13 -import Network.TLS.Handshake.Common13 - --- Put the server context in handshake mode. --- --- Expect to receive as first packet a client hello handshake message --- --- This is just a helper to pop the next message from the recv layer, --- and call handshakeServerWith. -handshakeServer :: ServerParams -> Context -> IO () -handshakeServer sparams ctx = liftIO $ do - hss <- recvPacketHandshake ctx - case hss of - [ch] -> handshakeServerWith sparams ctx ch - _ -> unexpected (show hss) (Just "client hello") - --- | 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. --- --- When the function returns, a new handshake has been succesfully negociated. --- On any error, a HandshakeFailed exception is raised. --- --- handshake protocol (<- receiving, -> sending, [] optional): --- (no session) (session resumption) --- <- client hello <- client hello --- -> server hello -> server hello --- -> [certificate] --- -> [server key xchg] --- -> [cert request] --- -> hello done --- <- [certificate] --- <- client key xchg --- <- [cert verify] --- <- change cipher -> change cipher --- <- finish -> finish --- -> change cipher <- change cipher --- -> finish <- finish --- -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () -handshakeServerWith sparams ctx clientHello@(ClientHello legacyVersion _ clientSession ciphers compressions exts _) = do - established <- ctxEstablished ctx - -- renego is not allowed in TLS 1.3 - when (established /= NotEstablished) $ do - ver <- usingState_ ctx (getVersionWithDefault TLS10) - when (ver == TLS13) $ throwCore $ Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage - -- rejecting client initiated renegotiation to prevent DOS. - eof <- ctxEOF ctx - let renegotiation = established == Established && not eof - when (renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx)) $ - throwCore $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation - -- check if policy allow this new handshake to happens - handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) - unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied") - updateMeasure ctx incrementNbHandshakes - - -- Handle Client hello - processHandshake ctx clientHello - - -- rejecting SSL2. RFC 6176 - when (legacyVersion == SSL2) $ throwCore $ Error_Protocol "SSL 2.0 is not supported" ProtocolVersion - -- rejecting SSL3. RFC 7568 - when (legacyVersion == SSL3) $ throwCore $ Error_Protocol "SSL 3.0 is not supported" ProtocolVersion - - -- Fallback SCSV: RFC7507 - -- TLS_FALLBACK_SCSV: {0x56, 0x00} - when (supportedFallbackScsv (ctxSupported ctx) && - (0x5600 `elem` ciphers) && - legacyVersion < TLS12) $ - throwCore $ Error_Protocol "fallback is not allowed" InappropriateFallback - -- choosing TLS version - let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of - Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == [] - _ -> [] - clientVersion = min TLS12 legacyVersion - serverVersions - | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) - | otherwise = supportedVersions $ ctxSupported ctx - mVersion = debugVersionForced $ serverDebug sparams - chosenVersion <- case mVersion of - Just cver -> return cver - Nothing -> - if (TLS13 `elem` serverVersions) && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of - Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported") ProtocolVersion - Just v -> return v - else case findHighestVersionFrom clientVersion serverVersions of - Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported") ProtocolVersion - Just v -> return v - - -- SNI (Server Name Indication) - let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of - Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) - where toHostName (ServerNameHostName hostName) = Just hostName - toHostName (ServerNameOther _) = Nothing - _ -> Nothing - maybe (return ()) (usingState_ ctx . setClientSNI) serverName - - -- TLS version dependent - if chosenVersion <= TLS12 then - handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession - else do - mapM_ ensureNullCompression compressions - -- fixme: we should check if the client random is the same as - -- that in the first client hello in the case of hello retry. - handshakeServerWithTLS13 sparams ctx chosenVersion exts ciphers serverName clientSession -handshakeServerWith _ _ _ = throwCore $ Error_Protocol "unexpected handshake message received in handshakeServerWith" HandshakeFailure - --- TLS 1.2 or earlier -handshakeServerWithTLS12 :: ServerParams - -> Context - -> Version - -> [ExtensionRaw] - -> [CipherID] - -> Maybe String - -> Version - -> [CompressionID] - -> Session - -> IO () -handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clientVersion compressions clientSession = do - extraCreds <- onServerNameIndication (serverHooks sparams) serverName - let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $ - extraCreds `mappend` sharedCredentials (ctxShared ctx) - - -- If compression is null, commonCompressions should be [0]. - when (null commonCompressions) $ throwCore $ - Error_Protocol "no compression in common with the client" HandshakeFailure - - -- When selecting a cipher we must ensure that it is allowed for the - -- TLS version but also that all its key-exchange requirements - -- will be met. - - -- Some ciphers require a signature and a hash. With TLS 1.2 the hash - -- algorithm is selected from a combination of server configuration and - -- the client "supported_signatures" extension. So we cannot pick - -- such a cipher if no hash is available for it. It's best to skip this - -- cipher and pick another one (with another key exchange). - - -- 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 - -- the resulting credentials. - - let possibleGroups = negotiatedGroupsInCommon ctx exts - possibleECGroups = possibleGroups `intersect` availableECGroups - possibleFFGroups = possibleGroups `intersect` availableFFGroups - hasCommonGroupForECDHE = not (null possibleECGroups) - hasCommonGroupForFFDHE = not (null possibleFFGroups) - hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) - canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE - hasCommonGroup cipher = - case cipherKeyExchange cipher of - CipherKeyExchange_DH_Anon -> canFFDHE - CipherKeyExchange_DHE_RSA -> canFFDHE - CipherKeyExchange_DHE_DSS -> canFFDHE - CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE - CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE - _ -> True -- group not used - - -- Ciphers are selected according to TLS version, availability of - -- (EC)DHE group and credential depending on key exchange. - cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher - selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) - - (creds, signatureCreds, ciphersFilteredVersion) - = case chosenVersion of - TLS12 -> let -- Build a list of all hash/signature algorithms in common between - -- client and server. - possibleHashSigAlgs = hashAndSignaturesInCommon ctx exts - - -- Check that a candidate signature credential will be compatible with - -- client & server hash/signature algorithms. This returns Just Int - -- in order to sort credentials according to server hash/signature - -- preference. When the certificate has no matching hash/signature in - -- 'possibleHashSigAlgs' the result is Nothing, and the credential will - -- not be used to sign. This avoids a failure later in 'decideHashSig'. - signingRank cred = - case credentialDigitalSignatureKey cred of - Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs - Nothing -> Nothing - - -- Finally compute credential lists and resulting cipher list. - -- - -- 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 RFC 8446 section 4.4.2.2). - -- The condition is based on resulting (EC)DHE ciphers so that - -- filtering credentials does not give advantage to a less secure - -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. - cltCreds = filterCredentialsWithHashSignatures exts allCreds - sigCltCreds = filterSortCredentials signingRank cltCreds - sigAllCreds = filterSortCredentials signingRank allCreds - cltCiphers = selectCipher cltCreds sigCltCreds - allCiphers = selectCipher allCreds sigAllCreds - - resultTuple = if cipherListCredentialFallback cltCiphers - then (allCreds, sigAllCreds, allCiphers) - else (cltCreds, sigCltCreds, cltCiphers) - in resultTuple - _ -> - let sigAllCreds = filterCredentials (isJust . credentialDigitalSignatureKey) allCreds - allCiphers = selectCipher allCreds sigAllCreds - in (allCreds, sigAllCreds, allCiphers) - - -- 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 client" HandshakeFailure - - let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion - - cred <- case cipherKeyExchange usedCipher of - CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds - CipherKeyExchange_DH_Anon -> return Nothing - CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds - CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning KX_DSS signatureCreds - CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds - CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds - _ -> throwCore $ Error_Protocol "key exchange algorithm not implemented" HandshakeFailure - - ems <- processExtendedMasterSec ctx chosenVersion MsgTClientHello exts - resumeSessionData <- case clientSession of - (Session (Just clientSessionId)) -> do - let resume = liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId - resume >>= validateSession serverName ems - (Session Nothing) -> return Nothing - - -- Currently, we don't send back EcPointFormats. In this case, - -- the client chooses EcPointFormat_Uncompressed. - case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of - Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs - _ -> return () - - doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts - - where - commonCiphers creds sigCreds = filter ((`elem` ciphers) . cipherID) (getCiphers sparams creds sigCreds) - commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions - usedCompression = head commonCompressions - - validateSession _ _ Nothing = return Nothing - validateSession 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. - | clientVersion < sessionVersion sd = return Nothing - | sessionCipher sd `notElem` ciphers = return Nothing - | sessionCompression sd `notElem` compressions = return Nothing - | isJust sni && sessionClientSNI sd /= sni = return Nothing - | ems && not emsSession = return Nothing - | not ems && emsSession = - let err = "client resumes an EMS session without EMS" - in throwCore $ Error_Protocol err HandshakeFailure - | otherwise = return m - where emsSession = SessionEMS `elem` sessionFlags sd - -doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher - -> Compression -> Session -> Maybe SessionData - -> [ExtensionRaw] -> IO () -doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts = do - case resumeSessionData of - Nothing -> do - handshakeSendServerData - liftIO $ contextFlush ctx - -- Receive client info until client Finished. - recvClientData sparams ctx - sendChangeCipherAndFinish ctx ServerRole - Just sessionData -> do - usingState_ ctx (setSession clientSession True) - serverhello <- makeServerHello clientSession - sendPacket ctx $ Handshake [serverhello] - let masterSecret = sessionSecret sessionData - usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret - logKey ctx (MasterSecret masterSecret) - sendChangeCipherAndFinish ctx ServerRole - recvChangeCipherAndFinish ctx - handshakeTerminate ctx - where - --- - -- When the client sends a certificate, check whether - -- it is acceptable for the application. - -- - --- - makeServerHello session = do - srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams - 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 - vf <- usingState_ ctx $ do - cvf <- getVerifiedData ClientRole - svf <- getVerifiedData ServerRole - return $ extensionEncode (SecureRenegotiation cvf $ Just svf) - return [ ExtensionRaw extensionID_SecureRenegotiation vf ] - else return [] - ems <- usingHState ctx getExtendedMasterSec - let emsExt | ems = let raw = extensionEncode ExtendedMasterSecret - in [ ExtensionRaw extensionID_ExtendedMasterSecret raw ] - | otherwise = [] - protoExt <- applicationProtocol ctx exts sparams - sniExt <- do - resuming <- usingState_ ctx isSessionResuming - if resuming - then return [] - else do - msni <- usingState_ ctx getClientSNI - 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 _ -> return [ ExtensionRaw extensionID_ServerName ""] - Nothing -> return [] - let extensions = sharedHelloExtensions (serverShared sparams) - ++ secRengExt ++ emsExt ++ protoExt ++ sniExt - usingState_ ctx (setVersion chosenVersion) - usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression - return $ ServerHello chosenVersion srand session (cipherID usedCipher) - (compressionID usedCompression) extensions - - handshakeSendServerData = do - serverSession <- newSession ctx - usingState_ ctx (setSession serverSession False) - serverhello <- makeServerHello serverSession - -- send ServerHello & Certificate & ServerKeyXchg & CertReq - let certMsg = case mcred of - Just (srvCerts, _) -> Certificates srvCerts - _ -> Certificates $ CertificateChain [] - sendPacket ctx $ Handshake [ serverhello, certMsg ] - - -- send server key exchange if needed - skx <- case cipherKeyExchange usedCipher of - CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon - CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA - CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE KX_DSS - CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA - CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA - _ -> return Nothing - maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx - - -- FIXME we don't do this on a Anonymous server - - -- When configured, send a certificate request with the DNs of all - -- configured CA certificates. - -- - -- Client certificates MUST NOT be accepted if not requested. - -- - when (serverWantClientCert sparams) $ do - usedVersion <- usingState_ ctx getVersion - let defaultCertTypes = [ CertificateType_RSA_Sign - , CertificateType_DSS_Sign - , CertificateType_ECDSA_Sign - ] - (certTypes, hashSigs) - | usedVersion < TLS12 = (defaultCertTypes, Nothing) - | otherwise = - let as = supportedHashSignatures $ ctxSupported ctx - in (nub $ mapMaybe hashSigToCertType as, Just as) - creq = CertRequest certTypes hashSigs - (map extractCAname $ serverCACertificates sparams) - usingHState ctx $ setCertReqSent True - sendPacket ctx (Handshake [creq]) - - -- Send HelloDone - sendPacket ctx (Handshake [ServerHelloDone]) - - setup_DHE = do - let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups - (dhparams, priv, pub) <- - case possibleFFGroups of - [] -> - let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams - in case findFiniteFieldGroup dhparams of - Just g -> do - usingHState ctx $ setNegotiatedGroup g - generateFFDHE ctx g - Nothing -> do - (priv, pub) <- generateDHE ctx dhparams - return (dhparams, priv, pub) - g:_ -> do - usingHState ctx $ setNegotiatedGroup g - generateFFDHE ctx g - - let serverParams = serverDHParamsFrom dhparams pub - - usingHState ctx $ setServerDHParams serverParams - usingHState ctx $ setDHPrivate priv - return serverParams - - -- Choosing a hash algorithm to sign (EC)DHE parameters - -- in ServerKeyExchange. Hash algorithm is not suggested by - -- the chosen cipher suite. So, it should be selected based on - -- the "signature_algorithms" extension in a client hello. - -- If RSA is also used for key exchange, this function is - -- not called. - decideHashSig pubKey = do - usedVersion <- usingState_ ctx getVersion - case usedVersion of - TLS12 -> do - let hashSigs = hashAndSignaturesInCommon ctx exts - case filter (pubKey `signatureCompatible`) hashSigs of - [] -> error ("no hash signature for " ++ pubkeyType pubKey) - x:_ -> return $ Just x - _ -> return Nothing - - generateSKX_DHE kxsAlg = do - serverParams <- setup_DHE - pubKey <- getLocalPublicKey ctx - mhashSig <- decideHashSig pubKey - signed <- digitallySignDHParams ctx serverParams pubKey mhashSig - case kxsAlg of - KX_RSA -> return $ SKX_DHE_RSA serverParams signed - KX_DSS -> return $ SKX_DHE_DSS serverParams signed - _ -> error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg) - - generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE - - setup_ECDHE grp = do - usingHState ctx $ setNegotiatedGroup grp - (srvpri, srvpub) <- generateECDHE ctx grp - let serverParams = ServerECDHParams grp srvpub - usingHState ctx $ setServerECDHParams serverParams - usingHState ctx $ setGroupPrivate srvpri - return serverParams - - generateSKX_ECDHE kxsAlg = do - let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups - grp <- case possibleECGroups of - [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure - g:_ -> return g - serverParams <- setup_ECDHE grp - pubKey <- getLocalPublicKey ctx - mhashSig <- decideHashSig pubKey - signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig - case kxsAlg of - KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed - KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed - _ -> error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg) - - -- create a DigitallySigned objects for DHParams or ECDHParams. - --- | receive Client data in handshake until the Finished handshake. --- --- <- [certificate] --- <- client key xchg --- <- [cert verify] --- <- change cipher --- <- finish --- -recvClientData :: ServerParams -> Context -> IO () -recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) - where processClientCertificate (Certificates certs) = do - clientCertificate sparams ctx certs - - -- FIXME: We should check whether the certificate - -- matches our request and that we support - -- verifying with that certificate. - - return $ RecvStateHandshake processClientKeyExchange - - processClientCertificate p = processClientKeyExchange p - - -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, - -- so we must process any packet, and in case of handshake call processHandshake manually. - processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify - processClientKeyExchange p = unexpected (show p) (Just "client key exchange") - - -- Check whether the client correctly signed the handshake. - -- If not, ask the application on how to proceed. - -- - processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do - processHandshake ctx hs - - certs <- checkValidClientCertChain ctx "change cipher message expected" - - usedVersion <- usingState_ ctx getVersion - -- Fetch all handshake messages up to now. - msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages - - pubKey <- usingHState ctx getRemotePublicKey - checkDigitalSignatureKey usedVersion pubKey - - verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig - clientCertVerify sparams ctx certs verif - return $ RecvStateNext expectChangeCipher - - processCertificateVerify p = do - chain <- usingHState ctx getClientCertChain - case chain of - Just cc | isNullCertificateChain cc -> return () - | otherwise -> throwCore $ Error_Protocol "cert verify message missing" UnexpectedMessage - Nothing -> return () - expectChangeCipher p - - expectChangeCipher ChangeCipherSpec = do - return $ RecvStateHandshake expectFinish - - expectChangeCipher p = unexpected (show p) (Just "change cipher") - - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") - -checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain -checkValidClientCertChain ctx errmsg = do - chain <- usingHState ctx getClientCertChain - let throwerror = Error_Protocol errmsg UnexpectedMessage - case chain of - Nothing -> throwCore throwerror - Just cc | isNullCertificateChain cc -> throwCore throwerror - | otherwise -> return cc - -hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] -hashAndSignaturesInCommon ctx exts = - let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of - -- See Section 7.4.1.4.1 of RFC 5246. - Nothing -> [(HashSHA1, SignatureECDSA) - ,(HashSHA1, SignatureRSA) - ,(HashSHA1, SignatureDSS)] - Just (SignatureAlgorithms sas) -> sas - sHashSigs = supportedHashSignatures $ ctxSupported ctx - -- 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'. - in sHashSigs `intersect` cHashSigs - -negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] -negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of - Just (NegotiatedGroups clientGroups) -> - let serverGroups = supportedGroups (ctxSupported ctx) - in serverGroups `intersect` clientGroups - _ -> [] - -credentialDigitalSignatureKey :: Credential -> Maybe PubKey -credentialDigitalSignatureKey cred - | isDigitalSignaturePair keys = Just pubkey - | otherwise = Nothing - where keys@(pubkey, _) = credentialPublicPrivateKeys cred - -filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials -filterCredentials p (Credentials l) = Credentials (filter p l) - -filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials -filterSortCredentials rankFun (Credentials creds) = - let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] - in Credentials [ cred | (Just _, cred) <- orderedPairs ] - -isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool -isCredentialAllowed ver exts 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 extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of - Nothing -> const True - Just (NegotiatedGroups sg) -> (`elem` sg) - | otherwise = const True - --- Filters a list of candidate credentials with credentialMatchesHashSignatures. --- --- Algorithms to filter with are taken from "signature_algorithms_cert" --- extension when it exists, else from "signature_algorithms" when clients do --- not implement the new extension (see RFC 8446 section 4.2.3). --- --- Resulting credential list can be used as input to the hybrid cipher-and- --- certificate selection for TLS12, or to the direct certificate selection --- simplified with TLS13. As filtering credential signatures with client- --- advertised algorithms is not supposed to cause negotiation failure, in case --- of dead end with the subsequent selection process, this process should always --- be restarted with the unfiltered credential list as input (see fallback --- certificate chains, described in same RFC section). --- --- Calling code should not forget to apply constraints of extension --- "signature_algorithms" to any signature-based key exchange derived from the --- output credentials. Respecting client constraints on KX signatures is --- mandatory but not implemented by this function. -filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials -filterCredentialsWithHashSignatures exts = - case withExt extensionID_SignatureAlgorithmsCert of - Just (SignatureAlgorithmsCert sas) -> withAlgs sas - Nothing -> - case withExt extensionID_SignatureAlgorithms of - Nothing -> id - Just (SignatureAlgorithms sas) -> withAlgs sas - where - withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello - withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) - --- returns True if certificate filtering with "signature_algorithms_cert" / --- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so --- handshake with lower security) -cipherListCredentialFallback :: [Cipher] -> Bool -cipherListCredentialFallback = all nonDH - where - nonDH x = case cipherKeyExchange x of - CipherKeyExchange_DHE_RSA -> False - CipherKeyExchange_DHE_DSS -> False - CipherKeyExchange_ECDHE_RSA -> False - CipherKeyExchange_ECDHE_ECDSA -> False - CipherKeyExchange_TLS13 -> False - _ -> True - -storePrivInfoServer :: MonadIO m => Context -> Credential -> m () -storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) - --- TLS 1.3 or later -handshakeServerWithTLS13 :: ServerParams - -> Context - -> Version - -> [ExtensionRaw] - -> [CipherID] - -> Maybe String - -> Session - -> IO () -handshakeServerWithTLS13 sparams ctx chosenVersion exts clientCiphers _serverName clientSession = do - when (any (\(ExtensionRaw eid _) -> eid == extensionID_PreSharedKey) $ init exts) $ - throwCore $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter - -- Deciding cipher. - -- 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 client" HandshakeFailure - let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion - usedHash = cipherHash usedCipher - rtt0 = case extensionLookup extensionID_EarlyData exts >>= 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 extensionID_KeyShare exts of - Nothing -> 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 "handshakeServerWithTLS13: invalid KeyShare value" - _ -> throwCore $ Error_Protocol "broken key_share" DecodeError - mshare <- findKeyShare keyShares serverGroups - case mshare of - Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession - Just keyShare -> doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash keyShare clientSession rtt0 - where - ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers - serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams) - serverGroups = supportedGroups (ctxSupported ctx) - -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry) -findKeyShare ks ggs = go ggs - 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 - -doHandshake13 :: ServerParams -> Context -> Version - -> Cipher -> [ExtensionRaw] - -> Hash -> KeyShareEntry - -> Session -> Bool - -> IO () -doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do - newSession ctx >>= \ss -> usingState_ ctx $ do - setSession ss False - setClientSupportsPHA supportsPHA - usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare - srand <- setServerParameter - -- ALPN is used in choosePSK - protoExt <- applicationProtocol ctx exts sparams - (psk, binderInfo, is0RTTvalid) <- choosePSK - earlyKey <- calculateEarlySecret ctx choice (Left psk) True - let earlySecret = pairBase earlyKey - clientEarlySecret = pairClient earlyKey - extensions <- checkBinder earlySecret binderInfo - hrr <- usingState_ ctx getTLS13HRR - let authenticated = isJust binderInfo - rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid - extraCreds <- usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) - let allCreds = filterCredentials (isCredentialAllowed chosenVersion exts) $ - extraCreds `mappend` sharedCredentials (ctxShared ctx) - ---------------------------------------------------------------- - established <- ctxEstablished ctx - if established /= NotEstablished then - if rtt0OK then do - usingHState ctx $ setTLS13HandshakeMode RTT0 - usingHState ctx $ setTLS13RTT0Status RTT0Accepted - else do - usingHState ctx $ setTLS13HandshakeMode RTT0 - usingHState ctx $ setTLS13RTT0Status RTT0Rejected - else - if authenticated then - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - else - -- FullHandshake or HelloRetryRequest - return () - mCredInfo <- if authenticated then return Nothing else decideCredentialInfo allCreds - (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare - ensureRecvComplete ctx - (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do - sendServerHello keyShare srand extensions - sendChangeCipherSpec13 ctx - ---------------------------------------------------------------- - handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe - let serverHandshakeSecret = triServer handKey - clientHandshakeSecret = triClient handKey - handSecret = triBase handKey - liftIO $ do - if rtt0OK && not (ctxQUICMode ctx) - then setRxState ctx usedHash usedCipher clientEarlySecret - else setRxState ctx usedHash usedCipher clientHandshakeSecret - setTxState ctx usedHash usedCipher serverHandshakeSecret - let mEarlySecInfo - | rtt0OK = Just $ EarlySecretInfo usedCipher clientEarlySecret - | otherwise = Nothing - handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret) - contextSync ctx $ SendServerHello exts mEarlySecInfo handSecInfo - ---------------------------------------------------------------- - sendExtensions rtt0OK protoExt - case mCredInfo of - Nothing -> return () - Just (cred, hashSig) -> sendCertAndVerify cred hashSig - let ServerTrafficSecret shs = serverHandshakeSecret - rawFinished <- makeFinished ctx usedHash shs - loadPacket13 ctx $ Handshake13 [rawFinished] - return (clientHandshakeSecret, handSecret) - sfSentTime <- getCurrentTimeFromBase - ---------------------------------------------------------------- - hChSf <- transcriptHash ctx - appKey <- calculateApplicationSecret ctx choice handSecret hChSf - let clientApplicationSecret0 = triClient appKey - serverApplicationSecret0 = triServer appKey - applicationSecret = triBase appKey - setTxState ctx usedHash usedCipher serverApplicationSecret0 - 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 - - let expectFinished hChBeforeCf (Finished13 verifyData) = liftIO $ do - let ClientTrafficSecret chs = clientHandshakeSecret - checkFinished ctx usedHash chs hChBeforeCf verifyData - handshakeTerminate13 ctx - setRxState ctx usedHash usedCipher clientApplicationSecret0 - sendNewSessionTicket applicationSecret sfSentTime - expectFinished _ hs = unexpected (show hs) (Just "finished 13") - - let expectEndOfEarlyData EndOfEarlyData13 = - setRxState ctx usedHash usedCipher clientHandshakeSecret - expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data") - - if not authenticated && serverWantClientCert sparams then - runRecvHandshake13 $ do - skip <- recvHandshake13 ctx expectCertificate - unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx) - recvHandshake13hash ctx expectFinished - ensureRecvComplete ctx - else if rtt0OK && not (ctxQUICMode ctx) then - setPendingActions ctx [PendingAction True expectEndOfEarlyData - ,PendingActionHash True expectFinished] - else - runRecvHandshake13 $ do - recvHandshake13hash ctx expectFinished - ensureRecvComplete ctx - where - choice = makeCipherChoice chosenVersion usedCipher - - setServerParameter = do - srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams - usingState_ ctx $ setVersion chosenVersion - failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher - return srand - - supportsPHA = case extensionLookup extensionID_PostHandshakeAuth exts >>= extensionDecode MsgTClientHello of - Just PostHandshakeAuth -> True - Nothing -> False - - choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of - Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> do - 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 Just tinfo = sessionTicketInfo sdata - psk = sessionSecret sdata - isFresh <- checkFreshness tinfo obfAge - (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata - if isPSKvalid && isFresh then - return (psk, Just (bnd,0::Int,len),is0RTTvalid) - else - -- fall back to full handshake - return (zero, Nothing, False) - _ -> return (zero, Nothing, False) - else return (zero, Nothing, False) - _ -> return (zero, Nothing, False) - - checkSessionEquality sdata = do - 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 = chosenVersion == sessionVersion sdata - isSameALPN = sessionALPN sdata == malpn - isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required - is0RTTvalid = isSameVersion && isSameCipher && isSameALPN - return (isPSKvalid, is0RTTvalid) - - 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 `bytesEq` binder') $ - decryptError "PSK binder validation failed" - let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n - return [ExtensionRaw extensionID_PreSharedKey selectedIdentity] - - decideCredentialInfo allCreds = do - cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts 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 - -- 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 - -- RFC 8446 section 4.4.2.2). - let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx - hashSigs = sHashSigs `intersect` cHashSigs - cltCreds = filterCredentialsWithHashSignatures exts allCreds - case credentialsFindForSigning13 hashSigs cltCreds of - Nothing -> - case credentialsFindForSigning13 hashSigs allCreds of - Nothing -> throwCore $ Error_Protocol "credential not found" HandshakeFailure - mcs -> return mcs - mcs -> return mcs - - sendServerHello keyShare srand extensions = do - let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare - selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion - extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare - : ExtensionRaw extensionID_SupportedVersions selectedVersion - : extensions - helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions' - loadPacket13 ctx $ Handshake13 [helo] - - sendCertAndVerify cred@(certChain, _) hashSig = 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] - usingHState ctx $ setCertReqSent True - - let CertificateChain cs = certChain - ess = replicate (length cs) [] - loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] - hChSc <- transcriptHash ctx - pubkey <- getLocalPublicKey ctx - vrfy <- makeCertVerify ctx pubkey hashSig hChSc - loadPacket13 ctx $ Handshake13 [vrfy] - - sendExtensions rtt0OK protoExt = do - msni <- liftIO $ usingState_ ctx getClientSNI - let sniExtension = case msni of - -- RFC6066: In this event, the server SHALL include - -- an extension of type "server_name" in the - -- (extended) server hello. The "extension_data" - -- field of this extension SHALL be empty. - Just _ -> Just $ ExtensionRaw extensionID_ServerName "" - Nothing -> Nothing - mgroup <- usingHState ctx getNegotiatedGroup - let serverGroups = supportedGroups (ctxSupported ctx) - groupExtension - | null serverGroups = Nothing - | maybe True (== head serverGroups) mgroup = Nothing - | otherwise = Just $ ExtensionRaw extensionID_NegotiatedGroups $ extensionEncode (NegotiatedGroups serverGroups) - let earlyDataExtension - | rtt0OK = Just $ ExtensionRaw extensionID_EarlyData $ extensionEncode (EarlyDataIndication Nothing) - | otherwise = Nothing - let extensions = sharedHelloExtensions (serverShared sparams) - ++ catMaybes [earlyDataExtension - ,groupExtension - ,sniExtension - ] - ++ protoExt - extensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions - loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions'] - - sendNewSessionTicket applicationSecret sfSentTime = when sendNST $ do - cfRecvTime <- getCurrentTimeFromBase - let rtt = cfRecvTime - sfSentTime - nonce <- getStateRNG ctx 32 - resumptionMasterSecret <- calculateResumptionSecret ctx choice applicationSecret - let life = toSeconds $ serverTicketLifetime sparams - psk = derivePSK choice resumptionMasterSecret nonce - (label, add) <- generateSession life psk rtt0max rtt - let nst = createNewSessionTicket life add nonce label rtt0max - sendPacket13 ctx $ Handshake13 [nst] - where - sendNST = PSK_DHE_KE `elem` dhModes - generateSession life psk maxSize rtt = do - Session (Just sessionId) <- newSession ctx - tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt) - sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk - let mgr = sharedSessionManager $ serverShared sparams - sessionEstablish mgr sessionId sdata - return (sessionId, ageAdd tinfo) - createNewSessionTicket life add nonce label maxSize = - NewSessionTicket13 life add nonce label extensions - where - tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize - extensions = [ExtensionRaw extensionID_EarlyData tedi] - toSeconds i | i < 0 = 0 - | i > 604800 = 604800 - | otherwise = fromIntegral i - - dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of - Just (PskKeyExchangeModes ms) -> ms - Nothing -> [] - - expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool - expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do - when (certCtx /= "") $ throwCore $ Error_Protocol "certificate request context MUST be empty" IllegalParameter - -- fixme checking _ext - clientCertificate sparams ctx certs - return $ isNullCertificateChain certs - expectCertificate hs = unexpected (show hs) (Just "certificate 13") - - hashSize = hashDigestSize usedHash - zero = B.replicate hashSize 0 - -expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () -expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do - certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected" - pubkey <- case cc of - [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure - c:_ -> return $ certPubKey $ getCertificate c - ver <- usingState_ ctx getVersion - checkDigitalSignatureKey ver pubkey - usingHState ctx $ setPublicKey pubkey - verif <- checkCertVerify ctx pubkey sigAlg sig hChCc - clientCertVerify sparams ctx certs verif -expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") - -helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO () -helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = 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 extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of - Just (NegotiatedGroups gs) -> gs - Nothing -> [] - possibleGroups = serverGroups `intersect` clientGroups - case possibleGroups of - [] -> throwCore $ Error_Protocol "no group in common with the client for HRR" HandshakeFailure - g:_ -> do - let serverKeyShare = extensionEncode $ KeyShareHRR g - selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion - extensions = [ExtensionRaw extensionID_KeyShare serverKeyShare - ,ExtensionRaw extensionID_SupportedVersions selectedVersion] - hrr = ServerHello13 hrrRandom clientSession (cipherID usedCipher) extensions - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - runPacketFlight ctx $ do - loadPacket13 ctx $ Handshake13 [hrr] - sendChangeCipherSpec13 ctx - handshakeServer sparams ctx - -findHighestVersionFrom :: Version -> [Version] -> Maybe Version -findHighestVersionFrom clientVersion allowedVersions = - case filter (clientVersion >=) $ sortOn Down allowedVersions of - [] -> Nothing - v:_ -> Just v - --- We filter our allowed ciphers here according to dynamic credential lists. --- Credentials 'creds' come from server parameters but also SNI callback. --- When the key exchange requires a signature, we use a --- 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) - where authorizedCKE cipher = - case cipherKeyExchange cipher of - CipherKeyExchange_RSA -> canEncryptRSA - CipherKeyExchange_DH_Anon -> True - CipherKeyExchange_DHE_RSA -> canSignRSA - CipherKeyExchange_DHE_DSS -> canSignDSS - CipherKeyExchange_ECDHE_RSA -> canSignRSA - CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA - -- unimplemented: non ephemeral DH & ECDH. - -- Note, these *should not* be implemented, and have - -- (for example) been removed in OpenSSL 1.1.0 - -- - CipherKeyExchange_DH_DSS -> False - CipherKeyExchange_DH_RSA -> False - CipherKeyExchange_ECDH_ECDSA -> False - CipherKeyExchange_ECDH_RSA -> False - CipherKeyExchange_TLS13 -> False -- not reached - - canSignDSS = KX_DSS `elem` signingAlgs - canSignRSA = KX_RSA `elem` signingAlgs - canSignECDSA = KX_ECDSA `elem` signingAlgs - canEncryptRSA = isJust $ credentialsFindForDecrypting creds - signingAlgs = credentialsListSigningAlgorithms sigCreds - -findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version -findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of - [] -> Nothing - v:_ -> Just v - where - svs = sortOn Down serverVersions - cvs = sortOn Down $ filter (> SSL3) clientVersions - -applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] -applicationProtocol ctx exts sparams = do - -- ALPN (Application Layer Protocol Negotiation) - case extensionLookup extensionID_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 extensionID_ApplicationLayerProtocolNegotiation - (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] - _ -> return [] - -credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) -credentialsFindForSigning13 hss0 creds = loop hss0 - where - loop [] = Nothing - loop (hs:hss) = case credentialsFindForSigning13' hs creds of - Nothing -> loop hss - Just cred -> Just (cred, hs) - --- See credentialsFindForSigning. -credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential -credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l - where - forSigning cred = case credentialDigitalSignatureKey cred of - Nothing -> False - Just pub -> pub `signatureCompatible13` sigAlg - -clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () -clientCertificate sparams ctx certs = do - -- run certificate recv hook - ctxWithHooks ctx (`hookRecvCertificates` certs) - -- Call application callback to see whether the - -- certificate chain is acceptable. - -- - usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException - case usage of - CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs - CertificateUsageReject reason -> certificateRejected reason - - -- Remember cert chain for later use. - -- - usingHState ctx $ setClientCertChain certs - -clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO () -clientCertVerify sparams ctx certs verif = do - if verif then do - -- When verification succeeds, commit the - -- client certificate chain to the context. - -- - usingState_ ctx $ setClientCertificateChain certs - return () - else do - -- Either verification failed because of an - -- invalid format (with an error message), or - -- the signature is wrong. In either case, - -- ask the application if it wants to - -- proceed, we will do that. - res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) - if res then do - -- When verification fails, but the - -- application callbacks accepts, we - -- also commit the client certificate - -- chain to the context. - usingState_ ctx $ setClientCertificateChain certs - else decryptError "verification failed" - -newCertReqContext :: Context -> IO CertReqContext -newCertReqContext ctx = getStateRNG ctx 32 - -requestCertificateServer :: ServerParams -> Context -> IO Bool -requestCertificateServer sparams ctx = do - tls13 <- tls13orLater ctx - supportsPHA <- usingState_ ctx getClientSupportsPHA - let ok = tls13 && supportsPHA - when ok $ do - certReqCtx <- newCertReqContext ctx - let certReq = makeCertRequest sparams ctx certReqCtx - bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - addCertRequest13 ctx certReq - sendPacket13 ctx $ Handshake13 [certReq] - return ok - -postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO () -postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = do - mCertReq <- getCertRequest13 ctx certCtx - when (isNothing mCertReq) $ throwCore $ Error_Protocol "unknown certificate request context" DecodeError - let certReq = fromJust "certReq" mCertReq - - -- fixme checking _ext - clientCertificate sparams ctx certs - - baseHState <- saveHState ctx - processHandshake13 ctx certReq - processHandshake13 ctx h - - (usedHash, _, level, applicationSecretN) <- getRxState ctx - unless (level == CryptApplicationSecret) $ - throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError - - let expectFinished hChBeforeCf (Finished13 verifyData) = do - checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData - void $ restoreHState ctx baseHState - expectFinished _ hs = unexpected (show hs) (Just "finished 13") - - -- Note: here the server could send updated NST too, however the library - -- currently has no API to handle resumption and client authentication - -- together, see discussion in #133 - if isNullCertificateChain certs - then setPendingActions ctx [ PendingActionHash False expectFinished ] - else setPendingActions ctx [ PendingActionHash False (expectCertVerify sparams ctx) - , PendingActionHash False expectFinished - ] - -postHandshakeAuthServerWith _ _ _ = - throwCore $ Error_Protocol "unexpected handshake message received in postHandshakeAuthServerWith" UnexpectedMessage - -contextSync :: Context -> ServerState -> IO () -contextSync ctx ctl = case ctxHandshakeSync ctx of - HandshakeSync _ sync -> sync ctx ctl + +module Network.TLS.Handshake.Server ( + handshakeServer, + handshakeServerWith, + requestCertificateServer, + postHandshakeAuthServerWith, +) where + +import Control.Exception (bracket) +import Control.Monad.State.Strict + +import Network.TLS.Context.Internal +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Common13 +import Network.TLS.Handshake.Server.ClientHello +import Network.TLS.Handshake.Server.ClientHello12 +import Network.TLS.Handshake.Server.ClientHello13 +import Network.TLS.Handshake.Server.ServerHello12 +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. +-- +-- Expect to receive as first packet a client hello handshake message +-- +-- This is just a helper to pop the next message from the recv layer, +-- 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") + +handshakeServerWith :: ServerParams -> Context -> Handshake -> 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. +-- +-- When the function returns, a new handshake has been succesfully negociated. +-- On any error, a HandshakeFailed exception is raised. +handshake :: ServerParams -> Context -> Handshake -> IO () +handshake sparams ctx clientHello = do + (chosenVersion, ch) <- processClientHello sparams ctx clientHello + 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 + handshakeServer sparams ctx + Just cliKeyShare -> do + r1 <- + sendServerHello13 sparams ctx cliKeyShare r0 ch + recvClientSecondFlight13 sparams ctx r1 ch + else do + r <- + processClinetHello12 sparams ctx ch + resumeSessionData <- + sendServerHello12 sparams ctx r ch + 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 diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.ClientHello ( + processClientHello, +) where + +import Network.TLS.Context.Internal +import Network.TLS.Extension +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Process +import Network.TLS.Imports +import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct + +processClientHello + :: ServerParams -> Context -> Handshake -> IO (Version, CH) +processClientHello sparams ctx clientHello@(ClientHello legacyVersion cran compressions ch@CH{..}) = do + established <- ctxEstablished ctx + -- renego is not allowed in TLS 1.3 + when (established /= NotEstablished) $ do + ver <- usingState_ ctx (getVersionWithDefault TLS12) + when (ver == TLS13) $ + throwCore $ + Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage + -- rejecting client initiated renegotiation to prevent DOS. + eof <- ctxEOF ctx + let renegotiation = established == Established && not eof + when + ( renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx) + ) + $ throwCore + $ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation + -- check if policy allow this new handshake to happens + handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams) + unless + handshakeAuthorized + (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) $ + throwCore $ + Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion + + -- Fallback SCSV: RFC7507 + -- TLS_FALLBACK_SCSV: {0x56, 0x00} + when + ( supportedFallbackScsv (ctxSupported ctx) + && (0x5600 `elem` chCiphers) + && legacyVersion < TLS12 + ) + $ throwCore + $ Error_Protocol "fallback is not allowed" InappropriateFallback + -- choosing TLS version + let clientVersions = case extensionLookup EID_SupportedVersions chExtensions + >>= extensionDecode MsgTClientHello of + Just (SupportedVersionsClientHello vers) -> vers -- fixme: vers == [] + _ -> [] + clientVersion = min TLS12 legacyVersion + serverVersions + | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) + | otherwise = supportedVersions $ ctxSupported ctx + mVersion = debugVersionForced $ serverDebug sparams + chosenVersion <- case mVersion of + Just cver -> return cver + Nothing -> + if (TLS13 `elem` serverVersions) && clientVersions /= [] + then case findHighestVersionFrom13 clientVersions serverVersions of + Nothing -> + throwCore $ + Error_Protocol + ("client versions " ++ show clientVersions ++ " is not supported") + ProtocolVersion + Just v -> return v + else case findHighestVersionFrom clientVersion serverVersions of + Nothing -> + throwCore $ + Error_Protocol + ("client version " ++ show clientVersion ++ " is not supported") + 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 + maybe (return ()) (usingState_ ctx . setClientSNI) serverName + return (chosenVersion, ch) +processClientHello _ _ _ = + throwCore $ + Error_Protocol + "unexpected handshake message received in handshakeServerWith" + HandshakeFailure + +findHighestVersionFrom :: Version -> [Version] -> Maybe Version +findHighestVersionFrom clientVersion allowedVersions = + case filter (clientVersion >=) $ sortOn Down allowedVersions of + [] -> Nothing + v : _ -> Just v + +findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version +findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of + [] -> Nothing + v : _ -> Just v + where + svs = sortOn Down serverVersions + cvs = sortOn Down $ filter (>= TLS12) clientVersions diff --git a/Network/TLS/Handshake/Server/ClientHello12.hs b/Network/TLS/Handshake/Server/ClientHello12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello12.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.ClientHello12 ( + processClinetHello12, +) where + +import Network.TLS.Cipher +import Network.TLS.Context.Internal +import Network.TLS.Credentials +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 (..)) + +---------------------------------------------------------------- + +-- TLS 1.2 or earlier +processClinetHello12 + :: ServerParams + -> Context + -> CH + -> IO (Cipher, Maybe Credential) +processClinetHello12 sparams ctx ch = do + let secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx + when secureRenegotiation $ checkSesecureRenegotiation ctx ch + serverName <- usingState_ ctx getClientSNI + extraCreds <- onServerNameIndication (serverHooks sparams) serverName + let (creds, signatureCreds, ciphersFilteredVersion) = + credsTriple sparams ctx 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 + mcred <- chooseCreds usedCipher creds signatureCreds + return (usedCipher, mcred) + +checkSesecureRenegotiation :: Context -> CH -> IO () +checkSesecureRenegotiation ctx CH{..} = do + -- RFC 5746: secure renegotiation + -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} + when (0xff `elem` chCiphers) $ + usingState_ ctx $ + setSecureRenegotiation True + case extensionLookup EID_SecureRenegotiation chExtensions of + Just content -> usingState_ ctx $ do + cvd <- getVerifyData ClientRole + let bs = extensionEncode (SecureRenegotiation cvd "") + unless (bs == content) $ + throwError $ + Error_Protocol + ("client verified data not matching: " ++ show cvd ++ ":" ++ show content) + HandshakeFailure + + setSecureRenegotiation True + _ -> return () + +---------------------------------------------------------------- + +credsTriple + :: ServerParams + -> Context + -> CH + -> Credentials + -> (Credentials, Credentials, [Cipher]) +credsTriple sparams ctx CH{..} extraCreds + | cipherListCredentialFallback cltCiphers = (allCreds, sigAllCreds, allCiphers) + | otherwise = (cltCreds, sigCltCreds, cltCiphers) + where + commonCiphers creds sigCreds = filter ((`elem` chCiphers) . cipherID) (getCiphers sparams creds sigCreds) + + allCreds = + filterCredentials (isCredentialAllowed TLS12 chExtensions) $ + extraCreds `mappend` sharedCredentials (ctxShared ctx) + + -- When selecting a cipher we must ensure that it is allowed for the + -- TLS version but also that all its key-exchange requirements + -- will be met. + + -- Some ciphers require a signature and a hash. With TLS 1.2 the hash + -- algorithm is selected from a combination of server configuration and + -- the client "supported_signatures" extension. So we cannot pick + -- such a cipher if no hash is available for it. It's best to skip this + -- cipher and pick another one (with another key exchange). + + -- 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 + -- the resulting credentials. + + possibleGroups = negotiatedGroupsInCommon ctx chExtensions + possibleECGroups = possibleGroups `intersect` availableECGroups + possibleFFGroups = possibleGroups `intersect` availableFFGroups + hasCommonGroupForECDHE = not (null possibleECGroups) + hasCommonGroupForFFDHE = not (null possibleFFGroups) + hasCustomGroupForFFDHE = isJust (serverDHEParams sparams) + canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE + hasCommonGroup cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_DH_Anon -> canFFDHE + CipherKeyExchange_DHE_RSA -> canFFDHE + CipherKeyExchange_DHE_DSA -> canFFDHE + CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE + CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE + _ -> True -- group not used + + -- Ciphers are selected according to TLS version, availability of + -- (EC)DHE group and credential depending on key exchange. + cipherAllowed cipher = cipherAllowedForVersion TLS12 cipher && hasCommonGroup cipher + selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) + + -- Build a list of all hash/signature algorithms in common between + -- client and server. + possibleHashSigAlgs = hashAndSignaturesInCommon ctx chExtensions + + -- Check that a candidate signature credential will be compatible with + -- client & server hash/signature algorithms. This returns Just Int + -- in order to sort credentials according to server hash/signature + -- preference. When the certificate has no matching hash/signature in + -- 'possibleHashSigAlgs' the result is Nothing, and the credential will + -- not be used to sign. This avoids a failure later in 'decideHashSig'. + signingRank cred = + case credentialDigitalSignatureKey cred of + Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs + Nothing -> Nothing + + -- Finally compute credential lists and resulting cipher list. + -- + -- 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 RFC 8446 section 4.4.2.2). + -- The condition is based on resulting (EC)DHE ciphers so that + -- filtering credentials does not give advantage to a less secure + -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon. + cltCreds = filterCredentialsWithHashSignatures chExtensions allCreds + sigCltCreds = filterSortCredentials signingRank cltCreds + sigAllCreds = filterSortCredentials signingRank allCreds + cltCiphers = selectCipher cltCreds sigCltCreds + allCiphers = selectCipher allCreds sigAllCreds + +chooseCreds :: Cipher -> Credentials -> Credentials -> IO (Maybe Credential) +chooseCreds usedCipher creds signatureCreds = case cipherKeyExchange usedCipher of + CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds + CipherKeyExchange_DH_Anon -> return Nothing + CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds + CipherKeyExchange_DHE_DSA -> return $ credentialsFindForSigning KX_DSA signatureCreds + CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds + CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds + _ -> + throwCore $ + Error_Protocol "key exchange algorithm not implemented" HandshakeFailure + +---------------------------------------------------------------- + +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 + _ -> [] + +---------------------------------------------------------------- + +filterSortCredentials + :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials +filterSortCredentials rankFun (Credentials creds) = + let orderedPairs = sortOn fst [(rankFun cred, cred) | cred <- creds] + in Credentials [cred | (Just _, cred) <- orderedPairs] + +-- returns True if certificate filtering with "signature_algorithms_cert" / +-- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so +-- handshake with lower security) +cipherListCredentialFallback :: [Cipher] -> Bool +cipherListCredentialFallback = all nonDH + where + nonDH x = case cipherKeyExchange x of + CipherKeyExchange_DHE_RSA -> False + CipherKeyExchange_DHE_DSA -> False + CipherKeyExchange_ECDHE_RSA -> False + CipherKeyExchange_ECDHE_ECDSA -> False + CipherKeyExchange_TLS13 -> False + _ -> True + +-- We filter our allowed ciphers here according to dynamic credential lists. +-- Credentials 'creds' come from server parameters but also SNI callback. +-- When the key exchange requires a signature, we use a +-- 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) + where + authorizedCKE cipher = + case cipherKeyExchange cipher of + CipherKeyExchange_RSA -> canEncryptRSA + CipherKeyExchange_DH_Anon -> True + CipherKeyExchange_DHE_RSA -> canSignRSA + CipherKeyExchange_DHE_DSA -> canSignDSA + CipherKeyExchange_ECDHE_RSA -> canSignRSA + CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA + -- unimplemented: non ephemeral DH & ECDH. + -- Note, these *should not* be implemented, and have + -- (for example) been removed in OpenSSL 1.1.0 + -- + CipherKeyExchange_DH_DSA -> False + CipherKeyExchange_DH_RSA -> False + CipherKeyExchange_ECDH_ECDSA -> False + CipherKeyExchange_ECDH_RSA -> False + CipherKeyExchange_TLS13 -> False -- not reached + canSignDSA = KX_DSA `elem` signingAlgs + canSignRSA = KX_RSA `elem` signingAlgs + canSignECDSA = KX_ECDSA `elem` signingAlgs + canEncryptRSA = isJust $ credentialsFindForDecrypting creds + signingAlgs = credentialsListSigningAlgorithms sigCreds diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.ClientHello13 ( + processClientHello13, + sendHRR, +) where + +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.State +import Network.TLS.Handshake.State13 +import Network.TLS.IO +import Network.TLS.Imports +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 + +-- TLS 1.3 or later +processClientHello13 + :: ServerParams + -> Context + -> CH + -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool)) +processClientHello13 sparams ctx CH{..} = do + when + (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) + $ throwCore + $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter + -- Deciding cipher. + -- 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.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 -> + 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)) + where + ciphersFilteredVersion = filter ((`elem` chCiphers) . cipherID) serverCiphers + serverCiphers = + filter + (cipherAllowedForVersion TLS13) + (supportedCiphers $ serverSupported sparams) + serverGroups = supportedGroups (ctxSupported ctx) + +findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry) +findKeyShare ks ggs = go ggs + 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 + +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 + [] -> + 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) diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/Common.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Server.Common ( + applicationProtocol, + checkValidClientCertChain, + clientCertificate, + credentialDigitalSignatureKey, + filterCredentials, + filterCredentialsWithHashSignatures, + isCredentialAllowed, + storePrivInfoServer, +) where + +import Control.Monad.State.Strict +import Data.X509 (ExtKeyUsageFlag (..)) + +import Network.TLS.Context.Internal +import Network.TLS.Credentials +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Certificate +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.State +import Network.TLS.Imports +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Util (catchException) +import Network.TLS.X509 + +checkValidClientCertChain + :: MonadIO m => Context -> String -> m CertificateChain +checkValidClientCertChain ctx errmsg = do + chain <- usingHState ctx getClientCertChain + let throwerror = Error_Protocol errmsg UnexpectedMessage + case chain of + Nothing -> throwCore throwerror + Just cc + | isNullCertificateChain cc -> throwCore throwerror + | otherwise -> return cc + +credentialDigitalSignatureKey :: Credential -> Maybe PubKey +credentialDigitalSignatureKey cred + | isDigitalSignaturePair keys = Just pubkey + | otherwise = Nothing + where + keys@(pubkey, _) = credentialPublicPrivateKeys cred + +filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials +filterCredentials p (Credentials l) = Credentials (filter p l) + +isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool +isCredentialAllowed ver exts 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. +-- +-- Algorithms to filter with are taken from "signature_algorithms_cert" +-- extension when it exists, else from "signature_algorithms" when clients do +-- not implement the new extension (see RFC 8446 section 4.2.3). +-- +-- Resulting credential list can be used as input to the hybrid cipher-and- +-- certificate selection for TLS12, or to the direct certificate selection +-- simplified with TLS13. As filtering credential signatures with client- +-- advertised algorithms is not supposed to cause negotiation failure, in case +-- of dead end with the subsequent selection process, this process should always +-- be restarted with the unfiltered credential list as input (see fallback +-- certificate chains, described in same RFC section). +-- +-- Calling code should not forget to apply constraints of extension +-- "signature_algorithms" to any signature-based key exchange derived from the +-- output credentials. Respecting client constraints on KX signatures is +-- mandatory but not implemented by this function. +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 + where + withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello + withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas) + +storePrivInfoServer :: MonadIO m => Context -> Credential -> m () +storePrivInfoServer ctx (cc, privkey) = void (storePrivInfo ctx cc privkey) + +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 [] + +clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () +clientCertificate sparams ctx certs = do + -- run certificate recv hook + ctxWithHooks ctx (`hookRecvCertificates` certs) + -- Call application callback to see whether the + -- certificate chain is acceptable. + -- + usage <- + liftIO $ + catchException + (onClientCertificate (serverHooks sparams) certs) + rejectOnException + case usage of + CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs + CertificateUsageReject reason -> certificateRejected reason + + -- Remember cert chain for later use. + -- + usingHState ctx $ setClientCertChain certs diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.ServerHello12 ( + sendServerHello12, +) where + +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Context.Internal +import Network.TLS.Credentials +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Certificate +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.Random +import Network.TLS.Handshake.Server.Common +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State +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.Types +import Network.TLS.X509 hiding (Certificate) + +sendServerHello12 + :: ServerParams + -> Context + -> (Cipher, Maybe Credential) + -> CH + -> 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 + build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions + let ff = serverhello : build [ServerHelloDone] + sendPacket12 ctx $ Handshake ff + contextFlush ctx + Just sessionData -> do + usingState_ ctx $ setSession chSession True + serverhello <- + makeServerHello sparams ctx usedCipher mcred chExtensions chSession + sendPacket12 ctx $ Handshake [serverhello] + let mainSecret = sessionSecret sessionData + usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret + logKey ctx $ MainSecret mainSecret + sendCCSandFinished ctx ServerRole + return resumeSessionData + +recoverSessionData :: Context -> CH -> 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 + +validateSession + :: [CipherID] + -> Maybe HostName + -> Bool + -> Maybe SessionData + -> IO (Maybe SessionData) +validateSession _ _ _ Nothing = return Nothing +validateSession 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 + | ems && not emsSession = return Nothing + | not ems && emsSession = + let err = "client resumes an EMS session without EMS" + in throwCore $ Error_Protocol err HandshakeFailure + | otherwise = return m + where + emsSession = SessionEMS `elem` sessionFlags sd + +sendServerFirstFlight + :: ServerParams + -> Context + -> Cipher + -> Maybe Credential + -> [ExtensionRaw] + -> IO ([Handshake] -> [Handshake]) +sendServerFirstFlight sparams ctx usedCipher mcred chExts = do + let b0 = id + let cc = case mcred of + Just (srvCerts, _) -> srvCerts + _ -> CertificateChain [] + let b1 = b0 . (Certificate cc :) + usingState_ ctx $ setServerCertificateChain cc + + -- send server key exchange if needed + skx <- case cipherKeyExchange usedCipher of + CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon + CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE KX_RSA + CipherKeyExchange_DHE_DSA -> Just <$> generateSKX_DHE KX_DSA + CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE KX_RSA + CipherKeyExchange_ECDHE_ECDSA -> Just <$> generateSKX_ECDHE KX_ECDSA + _ -> return Nothing + let b2 = case skx of + Nothing -> b1 + Just kx -> b1 . (ServerKeyXchg kx :) + + -- FIXME we don't do this on a Anonymous server + + -- When configured, send a certificate request with the DNs of all + -- configured CA certificates. + -- + -- Client certificates MUST NOT be accepted if not requested. + -- + if serverWantClientCert sparams + then do + let (certTypes, hashSigs) = + let as = supportedHashSignatures $ ctxSupported ctx + in (nub $ mapMaybe hashSigToCertType as, as) + creq = + CertRequest + certTypes + hashSigs + (map extractCAname $ serverCACertificates sparams) + usingHState ctx $ setCertReqSent True + return $ b2 . (creq :) + else return b2 + where + setup_DHE = do + let possibleFFGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableFFGroups + (dhparams, priv, pub) <- + case possibleFFGroups of + [] -> + let dhparams = fromJust $ serverDHEParams sparams + in case findFiniteFieldGroup dhparams of + Just g -> do + usingHState ctx $ setSupportedGroup g + generateFFDHE ctx g + Nothing -> do + (priv, pub) <- generateDHE ctx dhparams + return (dhparams, priv, pub) + g : _ -> do + usingHState ctx $ setSupportedGroup g + generateFFDHE ctx g + + let serverParams = serverDHParamsFrom dhparams pub + + usingHState ctx $ setServerDHParams serverParams + usingHState ctx $ setDHPrivate priv + return serverParams + + -- Choosing a hash algorithm to sign (EC)DHE parameters + -- in ServerKeyExchange. Hash algorithm is not suggested by + -- the chosen cipher suite. So, it should be selected based on + -- the "signature_algorithms" extension in a client hello. + -- 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 + [] -> error ("no hash signature for " ++ pubkeyType pubKey) + x : _ -> return x + + generateSKX_DHE kxsAlg = do + serverParams <- setup_DHE + pubKey <- getLocalPublicKey ctx + mhashSig <- decideHashSig pubKey + signed <- digitallySignDHParams ctx serverParams pubKey mhashSig + case kxsAlg of + KX_RSA -> return $ SKX_DHE_RSA serverParams signed + KX_DSA -> return $ SKX_DHE_DSA serverParams signed + _ -> + error ("generate skx_dhe unsupported key exchange signature: " ++ show kxsAlg) + + generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE + + setup_ECDHE grp = do + usingHState ctx $ setSupportedGroup grp + (srvpri, srvpub) <- generateECDHE ctx grp + let serverParams = ServerECDHParams grp srvpub + usingHState ctx $ setServerECDHParams serverParams + usingHState ctx $ setGroupPrivate srvpri + return serverParams + + generateSKX_ECDHE kxsAlg = do + let possibleECGroups = negotiatedGroupsInCommon ctx chExts `intersect` availableECGroups + grp <- case possibleECGroups of + [] -> throwCore $ Error_Protocol "no common group" HandshakeFailure + g : _ -> return g + serverParams <- setup_ECDHE grp + pubKey <- getLocalPublicKey ctx + mhashSig <- decideHashSig pubKey + signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig + case kxsAlg of + KX_RSA -> return $ SKX_ECDHE_RSA serverParams signed + KX_ECDSA -> return $ SKX_ECDHE_ECDSA serverParams signed + _ -> + error ("generate skx_ecdhe unsupported key exchange signature: " ++ show kxsAlg) + +--- +-- When the client sends a certificate, check whether +-- it is acceptable for the application. +-- +--- +makeServerHello + :: ServerParams + -> Context + -> Cipher + -> Maybe Credential + -> [ExtensionRaw] + -> Session + -> IO Handshake +makeServerHello sparams ctx usedCipher mcred chExts session = do + resuming <- usingState_ ctx isSessionResuming + srand <- + serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams + 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 [] + else do + msni <- usingState_ ctx getClientSNI + 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 _ -> return [ExtensionRaw EID_ServerName ""] + Nothing -> return [] + let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams + ticktExt + | not resuming && useTicket = + let raw = extensionEncode $ SessionTicket "" + in [ExtensionRaw EID_SessionTicket raw] + | otherwise = [] + let shExts = + sharedHelloExtensions (serverShared sparams) + ++ secRengExt + ++ emsExt + ++ protoExt + ++ sniExt + ++ ticktExt + usingState_ ctx $ setVersion TLS12 + usingHState ctx $ + setServerHelloParameters 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 + +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 + _ -> [] diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.ServerHello13 ( + sendServerHello13, +) where + +import Control.Monad.State.Strict +import qualified Data.ByteString as B + +import Network.TLS.Cipher +import Network.TLS.Context.Internal +import Network.TLS.Credentials +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Common13 +import Network.TLS.Handshake.Control +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.Random +import Network.TLS.Handshake.Server.Common +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State +import Network.TLS.Handshake.State13 +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 +import Network.TLS.Types +import Network.TLS.X509 + +sendServerHello13 + :: ServerParams + -> Context + -> KeyShareEntry + -> (Cipher, Hash, Bool) + -> CH + -> IO + ( SecretTriple ApplicationSecret + , ClientTrafficSecret HandshakeSecret + , Bool + , Bool + ) +sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) CH{..} = do + 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 + hrr <- usingState_ ctx getTLS13HRR + let authenticated = isJust binderInfo + rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid + extraCreds <- + usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams) + let allCreds = + filterCredentials (isCredentialAllowed TLS13 chExtensions) $ + extraCreds `mappend` sharedCredentials (ctxShared ctx) + ---------------------------------------------------------------- + established <- ctxEstablished ctx + if established /= NotEstablished + then + if rtt0OK + then do + usingHState ctx $ setTLS13HandshakeMode RTT0 + usingHState ctx $ setTLS13RTT0Status RTT0Accepted + else do + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + usingHState ctx $ setTLS13RTT0Status RTT0Rejected + else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey + -- else : FullHandshake or HelloRetryRequest + mCredInfo <- + if authenticated then return Nothing else decideCredentialInfo allCreds + (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare + ensureRecvComplete ctx + (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do + sendServerHello keyShare srand extensions + sendChangeCipherSpec13 ctx + ---------------------------------------------------------------- + handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe + let serverHandshakeSecret = triServer handKey + clientHandshakeSecret = triClient handKey + handSecret = triBase handKey + liftIO $ do + if rtt0OK && not (ctxQUICMode ctx) + then setRxRecordState ctx usedHash usedCipher clientEarlySecret + else setRxRecordState ctx usedHash usedCipher clientHandshakeSecret + setTxRecordState ctx usedHash usedCipher serverHandshakeSecret + let mEarlySecInfo + | rtt0OK = Just $ EarlySecretInfo usedCipher clientEarlySecret + | otherwise = Nothing + handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) + contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo + ---------------------------------------------------------------- + sendExtensions rtt0OK protoExt + case mCredInfo of + Nothing -> return () + Just (cred, hashSig) -> sendCertAndVerify cred hashSig + let ServerTrafficSecret shs = serverHandshakeSecret + rawFinished <- makeFinished ctx usedHash shs + loadPacket13 ctx $ Handshake13 [rawFinished] + return (clientHandshakeSecret, handSecret) + ---------------------------------------------------------------- + hChSf <- transcriptHash ctx + appKey <- calculateApplicationSecret ctx choice handSecret hChSf + let clientApplicationSecret0 = triClient appKey + serverApplicationSecret0 = triServer appKey + setTxRecordState ctx usedHash usedCipher serverApplicationSecret0 + 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 + 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) + + 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) + + 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 + -- 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 + -- RFC 8446 section 4.4.2.2). + let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx + hashSigs = sHashSigs `intersect` cHashSigs + cltCreds = filterCredentialsWithHashSignatures chExtensions allCreds + case credentialsFindForSigning13 hashSigs cltCreds of + Nothing -> + case credentialsFindForSigning13 hashSigs allCreds of + Nothing -> throwCore $ Error_Protocol "credential not found" HandshakeFailure + 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] + + sendCertAndVerify cred@(certChain, _) hashSig = 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] + usingHState ctx $ setCertReqSent True + + let CertificateChain cs = certChain + ess = replicate (length cs) [] + loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess] + liftIO $ usingState_ ctx $ setServerCertificateChain certChain + hChSc <- transcriptHash ctx + pubkey <- getLocalPublicKey ctx + vrfy <- makeCertVerify ctx pubkey hashSig hChSc + loadPacket13 ctx $ Handshake13 [vrfy] + + sendExtensions rtt0OK protoExt = do + msni <- liftIO $ usingState_ ctx getClientSNI + let sniExtension = case msni of + -- RFC6066: In this event, the server SHALL include + -- an extension of type "server_name" in the + -- (extended) server hello. The "extension_data" + -- field of this extension SHALL be empty. + Just _ -> Just $ ExtensionRaw EID_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 = + Just $ + ExtensionRaw EID_EarlyData $ + extensionEncode (EarlyDataIndication Nothing) + | otherwise = Nothing + let extensions = + sharedHelloExtensions (serverShared sparams) + ++ catMaybes + [ earlyDataExtension + , groupExtension + , sniExtension + ] + ++ 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 + +credentialsFindForSigning13 + :: [HashAndSignatureAlgorithm] + -> Credentials + -> Maybe (Credential, HashAndSignatureAlgorithm) +credentialsFindForSigning13 hss0 creds = loop hss0 + where + loop [] = Nothing + loop (hs : hss) = case credentialsFindForSigning13' hs creds of + Nothing -> loop hss + Just cred -> Just (cred, hs) + +-- See credentialsFindForSigning. +credentialsFindForSigning13' + :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential +credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l + where + forSigning cred = case credentialDigitalSignatureKey cred of + Nothing -> False + Just pub -> pub `signatureCompatible13` sigAlg + +contextSync :: Context -> ServerState -> IO () +contextSync ctx ctl = case ctxHandshakeSync ctx of + HandshakeSync _ sync -> sync ctx ctl diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.TLS.Handshake.Server.TLS12 ( + recvClientSecondFlight12, +) where + +import Control.Monad.State.Strict (gets) +import qualified Data.ByteString as B + +import Network.TLS.Context.Internal +import Network.TLS.Crypto +import Network.TLS.Handshake.Common +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.Server.Common +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State +import Network.TLS.IO +import Network.TLS.Imports +import Network.TLS.Packet hiding (getSession) +import Network.TLS.Parameters +import Network.TLS.Session +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Types +import Network.TLS.X509 hiding (Certificate) + +---------------------------------------------------------------- + +recvClientSecondFlight12 + :: ServerParams + -> Context + -> Maybe SessionData + -> IO () +recvClientSecondFlight12 sparams ctx resumeSessionData = do + case resumeSessionData of + Nothing -> do + recvClientCCC sparams ctx + mticket <- sessionEstablished ctx + case mticket of + Nothing -> return () + Just ticket -> do + let life = adjustLifetime $ serverTicketLifetime sparams + sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] + sendCCSandFinished ctx ServerRole + Just _ -> do + _ <- sessionEstablished ctx + recvCCSandFinished ctx + handshakeDone12 ctx + where + adjustLifetime i + | i < 0 = 0 + | i > 604800 = 604800 + | otherwise = fromIntegral i + +sessionEstablished :: Context -> IO (Maybe Ticket) +sessionEstablished ctx = do + session <- usingState_ ctx getSession + -- only callback the session established if we have a session + case session of + Session (Just sessionId) -> do + sessionData <- getSessionData ctx + let sessionId' = B.copy sessionId + sessionEstablish + (sharedSessionManager $ ctxShared ctx) + sessionId' + (fromJust sessionData) + _ -> return Nothing -- never reach + +---------------------------------------------------------------- + +-- | receive Client data in handshake until the Finished handshake. +-- +-- <- [certificate] +-- <- client key xchg +-- <- [cert verify] +-- <- change cipher +-- <- finish +recvClientCCC :: ServerParams -> Context -> IO () +recvClientCCC sparams ctx = runRecvState ctx (RecvStateHandshake expectClientCertificate) + where + expectClientCertificate (Certificate certs) = do + clientCertificate sparams ctx certs + processCertificate ctx ServerRole certs + + -- FIXME: We should check whether the certificate + -- matches our request and that we support + -- verifying with that certificate. + + return $ RecvStateHandshake $ expectClientKeyExchange True + expectClientCertificate p = expectClientKeyExchange False p + + -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, + -- so we must process any packet, and in case of handshake call processHandshake manually. + expectClientKeyExchange followedCertVerify (ClientKeyXchg ckx) = do + processClientKeyXchg ctx ckx + if followedCertVerify + then return $ RecvStateHandshake expectCertificateVerify + else return $ RecvStatePacket $ expectChangeCipherSpec ctx + expectClientKeyExchange _ p = unexpected (show p) (Just "client key exchange") + + expectCertificateVerify (CertVerify dsig) = do + certs <- checkValidClientCertChain ctx "change cipher message expected" + + usedVersion <- usingState_ ctx getVersion + -- Fetch all handshake messages up to now. + msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages + + pubKey <- usingHState ctx getRemotePublicKey + checkDigitalSignatureKey usedVersion pubKey + + verif <- checkCertificateVerify ctx usedVersion pubKey msgs dsig + processClientCertVerify sparams ctx certs verif + return $ RecvStatePacket $ expectChangeCipherSpec ctx + expectCertificateVerify p = unexpected (show p) (Just "client certificate verify") + +---------------------------------------------------------------- + +expectChangeCipherSpec :: Context -> Packet -> IO (RecvState IO) +expectChangeCipherSpec ctx ChangeCipherSpec = do + return $ RecvStateHandshake $ expectFinished ctx +expectChangeCipherSpec _ p = unexpected (show p) (Just "change cipher") + +---------------------------------------------------------------- + +-- process the client key exchange message. the protocol expects the initial +-- client version received in ClientHello, not the negotiated version. +-- in case the version mismatch, generate a random main secret +processClientKeyXchg :: Context -> ClientKeyXchgAlgorithmData -> IO () +processClientKeyXchg ctx (CKX_RSA encryptedPreMain) = do + (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 + logKey ctx (MainSecret mainSecret) +processClientKeyXchg ctx (CKX_DH clientDHValue) = do + rver <- usingState_ ctx getVersion + role <- usingState_ ctx getRole + + serverParams <- usingHState ctx getServerDHParams + let params = serverDHParamsToParams serverParams + unless (dhValid params $ dhUnwrapPublic clientDHValue) $ + throwCore $ + Error_Protocol "invalid client public key" IllegalParameter + + dhpriv <- usingHState ctx getDHPrivate + let preMain = dhGetShared params dhpriv clientDHValue + mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain + logKey ctx (MainSecret mainSecret) +processClientKeyXchg ctx (CKX_ECDH bytes) = do + ServerECDHParams grp _ <- usingHState ctx getServerECDHParams + case decodeGroupPublic grp bytes of + Left _ -> + throwCore $ + Error_Protocol "client public key cannot be decoded" 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 + +---------------------------------------------------------------- + +processClientCertVerify + :: ServerParams -> Context -> CertificateChain -> Bool -> IO () +processClientCertVerify _sparams ctx certs True = do + -- When verification succeeds, commit the + -- client certificate chain to the context. + -- + usingState_ ctx $ setClientCertificateChain certs + return () +processClientCertVerify sparams ctx certs False = do + -- Either verification failed because of an + -- invalid format (with an error message), or + -- the signature is wrong. In either case, + -- ask the application if it wants to + -- proceed, we will do that. + res <- onUnverifiedClientCert (serverHooks sparams) + if res + then do + -- When verification fails, but the + -- application callbacks accepts, we + -- also commit the client certificate + -- chain to the context. + usingState_ ctx $ setClientCertificateChain certs + else decryptError "verification failed" + +---------------------------------------------------------------- + +recvCCSandFinished :: Context -> IO () +recvCCSandFinished ctx = runRecvState ctx $ RecvStatePacket $ expectChangeCipherSpec ctx diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.TLS.Handshake.Server.TLS13 ( + recvClientSecondFlight13, + postHandshakeAuthServerWith, +) where + +import Control.Monad.State.Strict + +import Network.TLS.Cipher +import Network.TLS.Context.Internal +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.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 +import Network.TLS.Types +import Network.TLS.X509 + +recvClientSecondFlight13 + :: ServerParams + -> Context + -> ( SecretTriple ApplicationSecret + , ClientTrafficSecret HandshakeSecret + , Bool + , Bool + ) + -> CH + -> IO () +recvClientSecondFlight13 sparams ctx (appKey, clientHandshakeSecret, authenticated, rtt0OK) CH{..} = do + sfSentTime <- getCurrentTimeFromBase + let expectFinished' = + expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime + if not authenticated && serverWantClientCert sparams + then runRecvHandshake13 $ do + skip <- recvHandshake13 ctx $ expectCertificate sparams ctx + unless skip $ recvHandshake13hash ctx (expectCertVerify sparams ctx) + recvHandshake13hash ctx expectFinished' + ensureRecvComplete ctx + else + if rtt0OK && not (ctxQUICMode ctx) + then + setPendingRecvActions + ctx + [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret + , PendingRecvActionHash True $ + expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime + ] + else runRecvHandshake13 $ do + recvHandshake13hash ctx expectFinished' + ensureRecvComplete ctx + +expectFinished + :: MonadIO m + => ServerParams + -> Context + -> [ExtensionRaw] + -> SecretTriple ApplicationSecret + -> ClientTrafficSecret HandshakeSecret + -> Word64 + -> ByteString + -> Handshake13 + -> m () +expectFinished sparams ctx exts appKey clientHandshakeSecret sfSentTime hChBeforeCf (Finished13 verifyData) = liftIO $ do + modifyTLS13State ctx $ \st -> st{tls13stRecvCF = True} + (usedHash, usedCipher, _, _) <- getRxRecordState ctx + let ClientTrafficSecret chs = clientHandshakeSecret + checkFinished ctx usedHash chs hChBeforeCf verifyData + handshakeDone13 ctx + setRxRecordState ctx usedHash usedCipher clientApplicationSecret0 + sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime + where + applicationSecret = triBase appKey + clientApplicationSecret0 = triClient appKey +expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") + +expectEndOfEarlyData + :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO () +expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do + (usedHash, usedCipher, _, _) <- getRxRecordState ctx + setRxRecordState ctx usedHash usedCipher clientHandshakeSecret +expectEndOfEarlyData _ _ hs = unexpected (show hs) (Just "end of early data") + +expectCertificate + :: MonadIO m => ServerParams -> Context -> Handshake13 -> m Bool +expectCertificate sparams ctx (Certificate13 certCtx 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 + :: ServerParams + -> Context + -> Cipher + -> [ExtensionRaw] + -> BaseSecret ApplicationSecret + -> Word64 + -> IO () +sendNewSessionTicket sparams ctx usedCipher exts applicationSecret sfSentTime = when sendNST $ do + cfRecvTime <- getCurrentTimeFromBase + let rtt = cfRecvTime - sfSentTime + nonce <- 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] + where + choice = makeCipherChoice TLS13 usedCipher + rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams + sendNST = PSK_DHE_KE `elem` dhModes + + dhModes = case extensionLookup EID_PskKeyExchangeModes exts + >>= extensionDecode MsgTClientHello of + Just (PskKeyExchangeModes ms) -> ms + Nothing -> [] + + generateSession life psk maxSize rtt = do + Session (Just sessionId) <- newSession ctx + tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt) + sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk + let mgr = sharedSessionManager $ serverShared sparams + mticket <- sessionEstablish mgr sessionId sdata + let identity = fromMaybe sessionId mticket + return (identity, ageAdd tinfo) + + createNewSessionTicket life add nonce identity maxSize = + NewSessionTicket13 life add nonce identity extensions + where + tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize + extensions = [ExtensionRaw EID_EarlyData tedi] + 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 + certs@(CertificateChain cc) <- + checkValidClientCertChain ctx "finished 13 message expected" + pubkey <- case cc of + [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure + c : _ -> return $ certPubKey $ getCertificate c + ver <- usingState_ ctx getVersion + checkDigitalSignatureKey ver pubkey + usingHState ctx $ setPublicKey pubkey + verif <- checkCertVerify ctx pubkey sigAlg sig hChCc + clientCertVerify sparams ctx certs verif +expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") + +clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO () +clientCertVerify sparams ctx certs verif = do + if verif + then do + -- When verification succeeds, commit the + -- client certificate chain to the context. + -- + usingState_ ctx $ setClientCertificateChain certs + return () + else do + -- Either verification failed because of an + -- invalid format (with an error message), or + -- the signature is wrong. In either case, + -- ask the application if it wants to + -- proceed, we will do that. + res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) + if res + then do + -- When verification fails, but the + -- application callbacks accepts, we + -- also commit the client certificate + -- chain to the context. + 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 + + baseHState <- saveHState ctx + processHandshake13 ctx certReq + processHandshake13 ctx h + + (usedHash, _, level, applicationSecretN) <- getRxRecordState ctx + unless (level == CryptApplicationSecret) $ + throwCore $ + Error_Protocol + "tried post-handshake authentication without application traffic secret" + InternalError + + let expectFinished' hChBeforeCf (Finished13 verifyData) = do + checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData + void $ restoreHState ctx baseHState + expectFinished' _ hs = unexpected (show hs) (Just "finished 13") + + -- Note: here the server could send updated NST too, however the library + -- currently has no API to handle resumption and client authentication + -- together, see discussion in #133 + if isNullCertificateChain certs + then 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 diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -1,43 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.Signature --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.Signature - ( - createCertificateVerify - , checkCertificateVerify - , digitallySignDHParams - , digitallySignECDHParams - , digitallySignDHParamsVerify - , digitallySignECDHParamsVerify - , checkSupportedHashSignature - , certificateCompatible - , signatureCompatible - , signatureCompatible13 - , hashSigToCertType - , signatureParams - , decryptError - ) where -import Network.TLS.Crypto +module Network.TLS.Handshake.Signature ( + createCertificateVerify, + checkCertificateVerify, + digitallySignDHParams, + digitallySignECDHParams, + digitallySignDHParamsVerify, + digitallySignECDHParamsVerify, + checkSupportedHashSignature, + certificateCompatible, + signatureCompatible, + signatureCompatible13, + hashSigToCertType, + signatureParams, + decryptError, +) where + +import Control.Monad.State.Strict + import Network.TLS.Context.Internal -import Network.TLS.Parameters -import Network.TLS.Struct +import Network.TLS.Crypto +import Network.TLS.Handshake.Key +import Network.TLS.Handshake.State import Network.TLS.Imports -import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS, - encodeSignedDHParams, encodeSignedECDHParams) +import Network.TLS.Packet ( + encodeSignedDHParams, + encodeSignedECDHParams, + ) +import Network.TLS.Parameters import Network.TLS.State -import Network.TLS.Handshake.State -import Network.TLS.Handshake.Key -import Network.TLS.Util +import Network.TLS.Struct import Network.TLS.X509 -import Control.Monad.State.Strict - decryptError :: MonadIO m => String -> m a decryptError msg = throwCore $ Error_Protocol msg DecryptError @@ -45,26 +39,26 @@ -- Ed25519 and Ed448 have no assigned code point and are checked with extension -- "signature_algorithms" only. certificateCompatible :: PubKey -> [CertificateType] -> Bool -certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes -certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSS_Sign `elem` cTypes -certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes -certificateCompatible (PubKeyEd25519 _) _ = True -certificateCompatible (PubKeyEd448 _) _ = True -certificateCompatible _ _ = False +certificateCompatible (PubKeyRSA _) cTypes = CertificateType_RSA_Sign `elem` cTypes +certificateCompatible (PubKeyDSA _) cTypes = CertificateType_DSA_Sign `elem` cTypes +certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes +certificateCompatible (PubKeyEd25519 _) _ = True +certificateCompatible (PubKeyEd448 _) _ = True +certificateCompatible _ _ = False signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool -signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 -signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 -signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 -signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 -signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 -signatureCompatible (PubKeyDSA _) (_, SignatureDSS) = True -signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True -signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True -signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True -signatureCompatible _ (_, _) = False +signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 +signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 +signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 +signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 +signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 +signatureCompatible (PubKeyDSA _) (_, SignatureDSA) = True +signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True +signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True +signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True +signatureCompatible _ (_, _) = False -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the -- relation between hash in the HashAndSignatureAlgorithm and elliptic curve @@ -75,7 +69,7 @@ hashCurve HashSHA256 = Just P256 hashCurve HashSHA384 = Just P384 hashCurve HashSHA512 = Just P521 - hashCurve _ = Nothing + hashCurve _ = Nothing signatureCompatible13 pub hs = signatureCompatible pub hs -- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'. @@ -96,55 +90,52 @@ -- @RSA@ as the only supported client certificate algorithm for TLS 1.3. -- -- FIXME: Add RSA_PSS_PSS signatures when supported. --- hashSigToCertType :: HashAndSignatureAlgorithm -> Maybe CertificateType -- -hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign +hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign -- -hashSigToCertType (_, SignatureDSS) = Just CertificateType_DSS_Sign +hashSigToCertType (_, SignatureDSA) = Just CertificateType_DSA_Sign -- hashSigToCertType (_, SignatureECDSA) = Just CertificateType_ECDSA_Sign -- -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256) - = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384) - = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512) - = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureEd25519) - = Just CertificateType_Ed25519_Sign -hashSigToCertType (HashIntrinsic, SignatureEd448) - = Just CertificateType_Ed448_Sign +hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256) = + Just CertificateType_RSA_Sign +hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384) = + Just CertificateType_RSA_Sign +hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512) = + Just CertificateType_RSA_Sign +hashSigToCertType (HashIntrinsic, SignatureEd25519) = + Just CertificateType_Ed25519_Sign +hashSigToCertType (HashIntrinsic, SignatureEd448) = + Just CertificateType_Ed448_Sign -- hashSigToCertType _ = Nothing -checkCertificateVerify :: Context - -> Version - -> PubKey - -> ByteString - -> DigitallySigned - -> IO Bool -checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) = - case (usedVersion, hashSigAlg) of - (TLS12, Nothing) -> return False - (TLS12, Just hs) | pubKey `signatureCompatible` hs -> doVerify - | otherwise -> return False - (_, Nothing) -> doVerify - (_, Just _) -> return False +checkCertificateVerify + :: Context + -> Version + -> PubKey + -> ByteString + -> DigitallySigned + -> IO Bool +checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) + | pubKey `signatureCompatible` hashSigAlg = doVerify + | otherwise = return False where doVerify = - prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>= - signatureVerifyWithCertVerifyData ctx digSig + prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs + >>= signatureVerifyWithCertVerifyData ctx digSig -createCertificateVerify :: Context - -> Version - -> PubKey - -> Maybe HashAndSignatureAlgorithm -- TLS12 only - -> ByteString - -> IO DigitallySigned +createCertificateVerify + :: Context + -> Version + -> PubKey + -> HashAndSignatureAlgorithm -- TLS12 only + -> ByteString + -> IO DigitallySigned createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs = - prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs >>= - signatureCreateWithCertVerifyData ctx hashSigAlg + prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs + >>= signatureCreateWithCertVerifyData ctx hashSigAlg type CertVerifyData = (SignatureParams, ByteString) @@ -152,149 +143,163 @@ -- the SHA1_MD5 algorithm expect an already digested data buildVerifyData :: SignatureParams -> ByteString -> CertVerifyData buildVerifyData (RSAParams SHA1_MD5 enc) bs = (RSAParams SHA1_MD5 enc, hashFinal $ hashUpdate (hashInit SHA1_MD5) bs) -buildVerifyData sigParam bs = (sigParam, bs) +buildVerifyData sigParam bs = (sigParam, bs) -prepareCertificateVerifySignatureData :: Context - -> Version - -> PubKey - -> Maybe HashAndSignatureAlgorithm -- TLS12 only - -> ByteString - -> IO CertVerifyData -prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs - | usedVersion == SSL3 = do - (hashCtx, params, generateCV_SSL) <- - case pubKey of - PubKeyRSA _ -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL) - PubKeyDSA _ -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS) - _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ pubkeyType pubKey) - Just masterSecret <- usingHState ctx $ gets hstMasterSecret - return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) - | usedVersion == TLS10 || usedVersion == TLS11 = - return $ buildVerifyData (signatureParams pubKey Nothing) msgs - | otherwise = return (signatureParams pubKey hashSigAlg, msgs) +prepareCertificateVerifySignatureData + :: Context + -> Version + -> PubKey + -> HashAndSignatureAlgorithm -- TLS12 only + -> ByteString + -> IO CertVerifyData +prepareCertificateVerifySignatureData _ctx _usedVersion pubKey hashSigAlg msgs = + return (signatureParams pubKey hashSigAlg, msgs) -signatureParams :: PubKey -> Maybe HashAndSignatureAlgorithm -> SignatureParams +signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of - Just (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 - Just (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 - Just (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 - Just (HashSHA1 , SignatureRSA) -> RSAParams SHA1 RSApkcs1 - Just (HashIntrinsic , SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss - Just (HashIntrinsic , SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss - Just (HashIntrinsic , SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss - Nothing -> RSAParams SHA1_MD5 RSApkcs1 - Just (hsh , SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) - Just (_ , sigAlg) -> error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) + (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 + (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 + (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 + (HashSHA1, SignatureRSA) -> RSAParams SHA1 RSApkcs1 + (HashIntrinsic, SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss + (HashIntrinsic, SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss + (HashIntrinsic, SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss + (hsh, SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) + (_, sigAlg) -> + error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of - Nothing -> DSSParams - Just (HashSHA1, SignatureDSS) -> DSSParams - Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" - Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg) + (HashSHA1, SignatureDSA) -> DSAParams + (_, SignatureDSA) -> error "invalid DSA hash choice, only SHA1 allowed" + (_, sigAlg) -> + error ("signature algorithm is incompatible with DSA: " ++ show sigAlg) signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of - Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 - Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 - Just (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 - Just (HashSHA1 , SignatureECDSA) -> ECDSAParams SHA1 - Nothing -> ECDSAParams SHA1 - Just (hsh , SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) - Just (_ , sigAlg) -> error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) + (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 + (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 + (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 + (HashSHA1, SignatureECDSA) -> ECDSAParams SHA1 + (hsh, SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) + (_, sigAlg) -> + error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of - Nothing -> Ed25519Params - Just (HashIntrinsic , SignatureEd25519) -> Ed25519Params - Just (hsh , SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) - Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) + (HashIntrinsic, SignatureEd25519) -> Ed25519Params + (hsh, SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) + (_, sigAlg) -> + error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of - Nothing -> Ed448Params - Just (HashIntrinsic , SignatureEd448) -> Ed448Params - Just (hsh , SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) - Just (_ , sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) + (HashIntrinsic, SignatureEd448) -> Ed448Params + (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) + (_, sigAlg) -> + error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") -signatureCreateWithCertVerifyData :: Context - -> Maybe HashAndSignatureAlgorithm - -> CertVerifyData - -> IO DigitallySigned +signatureCreateWithCertVerifyData + :: Context + -> HashAndSignatureAlgorithm + -> CertVerifyData + -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do - cc <- usingState_ ctx isClientContext - DigitallySigned malg <$> signPrivate ctx cc sigParam toSign + role <- usingState_ ctx getRole + DigitallySigned malg <$> signPrivate ctx role sigParam toSign signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion let (sigParam, toVerify) = case (usedVersion, hashSigAlg) of - (TLS12, Nothing) -> error "expecting hash and signature algorithm in a TLS12 digitally signed structure" - (TLS12, Just hs) | pubKey `signatureCompatible` hs -> (signatureParams pubKey hashSigAlg, toVerifyData) - | otherwise -> error "expecting different signature algorithm" - (_, Nothing) -> buildVerifyData (signatureParams pubKey Nothing) toVerifyData - (_, Just _) -> error "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" + (TLS12, hs) + | pubKey `signatureCompatible` hs -> + (signatureParams pubKey hashSigAlg, toVerifyData) + | otherwise -> + error "expecting different signature algorithm" + _ -> + error + "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) -signatureVerifyWithCertVerifyData :: Context - -> DigitallySigned - -> CertVerifyData - -> IO Bool +signatureVerifyWithCertVerifyData + :: Context + -> DigitallySigned + -> CertVerifyData + -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned hs bs) (sigParam, toVerify) = do checkSupportedHashSignature ctx hs verifyPublic ctx sigParam toVerify bs -digitallySignParams :: Context -> ByteString -> PubKey -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned +digitallySignParams + :: Context + -> ByteString + -> PubKey + -> HashAndSignatureAlgorithm + -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg = let sigParam = signatureParams pubKey hashSigAlg - in signatureCreateWithCertVerifyData ctx hashSigAlg (buildVerifyData sigParam signatureData) + in signatureCreateWithCertVerifyData + ctx + hashSigAlg + (buildVerifyData sigParam signatureData) -digitallySignDHParams :: Context - -> ServerDHParams - -> PubKey - -> Maybe HashAndSignatureAlgorithm -- TLS12 only - -> IO DigitallySigned +digitallySignDHParams + :: Context + -> ServerDHParams + -> PubKey + -> HashAndSignatureAlgorithm -- TLS12 only + -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do - dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams + dhParamsData <- + withClientAndServerRandom ctx $ encodeSignedDHParams serverParams digitallySignParams ctx dhParamsData pubKey mhash -digitallySignECDHParams :: Context - -> ServerECDHParams - -> PubKey - -> Maybe HashAndSignatureAlgorithm -- TLS12 only - -> IO DigitallySigned +digitallySignECDHParams + :: Context + -> ServerECDHParams + -> PubKey + -> HashAndSignatureAlgorithm -- TLS12 only + -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do - ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams + ecdhParamsData <- + withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams digitallySignParams ctx ecdhParamsData pubKey mhash -digitallySignDHParamsVerify :: Context - -> ServerDHParams - -> PubKey - -> DigitallySigned - -> IO Bool +digitallySignDHParamsVerify + :: Context + -> ServerDHParams + -> PubKey + -> DigitallySigned + -> IO Bool digitallySignDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedDHParams dhparams signatureVerify ctx signature pubKey expectedData -digitallySignECDHParamsVerify :: Context - -> ServerECDHParams - -> PubKey - -> DigitallySigned - -> IO Bool +digitallySignECDHParamsVerify + :: Context + -> ServerECDHParams + -> PubKey + -> DigitallySigned + -> IO Bool digitallySignECDHParamsVerify ctx dhparams pubKey signature = do expectedData <- withClientAndServerRandom ctx $ encodeSignedECDHParams dhparams signatureVerify ctx signature pubKey expectedData -withClientAndServerRandom :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b +withClientAndServerRandom + :: Context -> (ClientRandom -> ServerRandom -> b) -> IO b withClientAndServerRandom ctx f = do - (cran, sran) <- usingHState ctx $ (,) <$> gets hstClientRandom - <*> (fromJust "withClientAndServer : server random" <$> gets hstServerRandom) + (cran, sran) <- + usingHState ctx $ + (,) + <$> gets hstClientRandom + <*> (fromJust <$> gets hstServerRandom) return $ f cran sran -- verify that the hash and signature selected by the peer is supported in -- the local configuration -checkSupportedHashSignature :: Context -> Maybe HashAndSignatureAlgorithm -> IO () -checkSupportedHashSignature _ Nothing = return () -checkSupportedHashSignature ctx (Just hs) = +checkSupportedHashSignature + :: Context -> HashAndSignatureAlgorithm -> IO () +checkSupportedHashSignature ctx hs = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ let msg = "unsupported hash and signature algorithm: " ++ show hs in throwCore $ Error_Protocol msg IllegalParameter diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -1,375 +1,382 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.State - ( HandshakeState(..) - , HandshakeDigest(..) - , HandshakeMode13(..) - , RTT0Status(..) - , CertReqCBdata - , HandshakeM - , newEmptyHandshake - , runHandshake + +module Network.TLS.Handshake.State ( + HandshakeState (..), + HandshakeDigest (..), + HandshakeMode13 (..), + RTT0Status (..), + CertReqCBdata, + HandshakeM, + newEmptyHandshake, + runHandshake, + -- * key accessors - , setPublicKey - , setPublicPrivateKeys - , getLocalPublicPrivateKeys - , getRemotePublicKey - , setServerDHParams - , getServerDHParams - , setServerECDHParams - , getServerECDHParams - , setDHPrivate - , getDHPrivate - , setGroupPrivate - , getGroupPrivate + setPublicKey, + setPublicPrivateKeys, + getLocalPublicPrivateKeys, + getRemotePublicKey, + setServerDHParams, + getServerDHParams, + setServerECDHParams, + getServerECDHParams, + setDHPrivate, + getDHPrivate, + setGroupPrivate, + getGroupPrivate, + -- * cert accessors - , setClientCertSent - , getClientCertSent - , setCertReqSent - , getCertReqSent - , setClientCertChain - , getClientCertChain - , setCertReqToken - , getCertReqToken - , setCertReqCBdata - , getCertReqCBdata - , setCertReqSigAlgsCert - , getCertReqSigAlgsCert + setClientCertSent, + getClientCertSent, + setCertReqSent, + getCertReqSent, + setClientCertChain, + getClientCertChain, + setCertReqToken, + getCertReqToken, + setCertReqCBdata, + getCertReqCBdata, + setCertReqSigAlgsCert, + getCertReqSigAlgsCert, + -- * digest accessors - , addHandshakeMessage - , updateHandshakeDigest - , getHandshakeMessages - , getHandshakeMessagesRev - , getHandshakeDigest - , foldHandshakeDigest - -- * master secret - , setMasterSecret - , setMasterSecretFromPre + addHandshakeMessage, + updateHandshakeDigest, + getHandshakeMessages, + getHandshakeMessagesRev, + getHandshakeDigest, + foldHandshakeDigest, + + -- * main secret + setMainSecret, + setMainSecretFromPre, + -- * misc accessor - , getPendingCipher - , setServerHelloParameters - , setExtendedMasterSec - , getExtendedMasterSec - , setNegotiatedGroup - , getNegotiatedGroup - , setTLS13HandshakeMode - , getTLS13HandshakeMode - , setTLS13RTT0Status - , getTLS13RTT0Status - , setTLS13EarlySecret - , getTLS13EarlySecret - , setTLS13ResumptionSecret - , getTLS13ResumptionSecret - , setCCS13Sent - , getCCS13Sent - ) where + getPendingCipher, + setServerHelloParameters, + setExtendedMainSecret, + getExtendedMainSecret, + setSupportedGroup, + getSupportedGroup, + setTLS13HandshakeMode, + getTLS13HandshakeMode, + setTLS13RTT0Status, + getTLS13RTT0Status, + setTLS13EarlySecret, + getTLS13EarlySecret, + setTLS13ResumptionSecret, + getTLS13ResumptionSecret, + setCCS13Sent, + getCCS13Sent, +) where -import Network.TLS.Util -import Network.TLS.Struct -import Network.TLS.Record.State -import Network.TLS.Packet -import Network.TLS.Crypto +import Control.Monad.State.Strict +import Data.ByteArray (ByteArrayAccess) +import Data.X509 (CertificateChain) + import Network.TLS.Cipher import Network.TLS.Compression -import Network.TLS.Types +import Network.TLS.Crypto import Network.TLS.Imports -import Control.Monad.State.Strict -import Data.X509 (CertificateChain) -import Data.ByteArray (ByteArrayAccess) +import Network.TLS.Packet +import Network.TLS.Record.State +import Network.TLS.Struct +import Network.TLS.Types +import Network.TLS.Util data HandshakeKeyState = HandshakeKeyState - { hksRemotePublicKey :: !(Maybe PubKey) - , hksLocalPublicPrivateKeys :: !(Maybe (PubKey, PrivKey)) - } deriving (Show) + { hksRemotePublicKey :: Maybe PubKey + , hksLocalPublicPrivateKeys :: Maybe (PubKey, PrivKey) + } + deriving (Show) -data HandshakeDigest = HandshakeMessages [ByteString] - | HandshakeDigestContext HashCtx - deriving (Show) +data HandshakeDigest + = HandshakeMessages [ByteString] + | HandshakeDigestContext HashCtx + deriving (Show) data HandshakeState = HandshakeState - { hstClientVersion :: !Version - , hstClientRandom :: !ClientRandom - , hstServerRandom :: !(Maybe ServerRandom) - , hstMasterSecret :: !(Maybe ByteString) - , hstKeyState :: !HandshakeKeyState - , hstServerDHParams :: !(Maybe ServerDHParams) - , hstDHPrivate :: !(Maybe DHPrivate) - , hstServerECDHParams :: !(Maybe ServerECDHParams) - , hstGroupPrivate :: !(Maybe GroupPrivate) - , hstHandshakeDigest :: !HandshakeDigest - , hstHandshakeMessages :: [ByteString] - , hstCertReqToken :: !(Maybe ByteString) - -- ^ Set to Just-value when a TLS13 certificate request is received - , hstCertReqCBdata :: !(Maybe CertReqCBdata) - -- ^ Set to Just-value when a certificate request is received - , hstCertReqSigAlgsCert :: !(Maybe [HashAndSignatureAlgorithm]) - -- ^ In TLS 1.3, these are separate from the certificate - -- issuer signature algorithm hints in the callback data. - -- In TLS 1.2 the same list is overloaded for both purposes. - -- Not present in TLS 1.1 and earlier - , hstClientCertSent :: !Bool - -- ^ Set to true when a client certificate chain was sent - , hstCertReqSent :: !Bool - -- ^ Set to true when a certificate request was sent. This applies - -- only to requests sent during handshake (not post-handshake). - , hstClientCertChain :: !(Maybe CertificateChain) - , hstPendingTxState :: Maybe RecordState - , hstPendingRxState :: Maybe RecordState - , hstPendingCipher :: Maybe Cipher - , hstPendingCompression :: Compression - , hstExtendedMasterSec :: Bool - , hstNegotiatedGroup :: Maybe Group - , hstTLS13HandshakeMode :: HandshakeMode13 - , hstTLS13RTT0Status :: !RTT0Status - , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) + { hstClientVersion :: Version + , hstClientRandom :: ClientRandom + , hstServerRandom :: Maybe ServerRandom + , hstMainSecret :: Maybe ByteString + , hstKeyState :: HandshakeKeyState + , hstServerDHParams :: Maybe ServerDHParams + , hstDHPrivate :: Maybe DHPrivate + , hstServerECDHParams :: Maybe ServerECDHParams + , hstGroupPrivate :: Maybe GroupPrivate + , hstHandshakeDigest :: HandshakeDigest + , hstHandshakeMessages :: [ByteString] + , hstCertReqToken :: Maybe ByteString + -- ^ Set to Just-value when a TLS13 certificate request is received + , hstCertReqCBdata :: Maybe CertReqCBdata + -- ^ Set to Just-value when a certificate request is received + , hstCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] + -- ^ In TLS 1.3, these are separate from the certificate + -- issuer signature algorithm hints in the callback data. + -- In TLS 1.2 the same list is overloaded for both purposes. + -- Not present in TLS 1.1 and earlier + , hstClientCertSent :: Bool + -- ^ Set to true when a client certificate chain was sent + , hstCertReqSent :: Bool + -- ^ Set to true when a certificate request was sent. This applies + -- only to requests sent during handshake (not post-handshake). + , hstClientCertChain :: Maybe CertificateChain + , hstPendingTxState :: Maybe RecordState + , hstPendingRxState :: Maybe RecordState + , hstPendingCipher :: Maybe Cipher + , hstPendingCompression :: Compression + , hstExtendedMainSecret :: Bool + , hstSupportedGroup :: Maybe Group + , hstTLS13HandshakeMode :: HandshakeMode13 + , hstTLS13RTT0Status :: RTT0Status + , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) - , hstCCS13Sent :: !Bool - } deriving (Show) - -{- | When we receive a CertificateRequest from a server, a just-in-time - callback is issued to the application to obtain a suitable certificate. - Somewhat unfortunately, the callback parameters don't abstract away the - details of the TLS 1.2 Certificate Request message, which combines the - legacy @certificate_types@ and new @supported_signature_algorithms@ - parameters is a rather subtle way. - - TLS 1.2 also (again unfortunately, in the opinion of the author of this - comment) overloads the signature algorithms parameter to constrain not only - the algorithms used in TLS, but also the algorithms used by issuing CAs in - the X.509 chain. Best practice is to NOT treat such that restriction as a - MUST, but rather take it as merely a preference, when a choice exists. If - the best chain available does not match the provided signature algorithm - list, go ahead and use it anyway, it will probably work, and the server may - not even care about the issuer CAs at all, it may be doing DANE or have - explicit mappings for the client's public key, ... - - The TLS 1.3 @CertificateRequest@ message, drops @certificate_types@ and no - longer overloads @supported_signature_algorithms@ to cover X.509. It also - includes a new opaque context token that the client must echo back, which - makes certain client authentication replay attacks more difficult. We will - store that context separately, it does not need to be presented in the user - callback. The certificate signature algorithms preferred by the peer are - now in the separate @signature_algorithms_cert@ extension, but we cannot - report these to the application callback without an API change. The good - news is that filtering the X.509 signature types is generally unnecessary, - unwise and difficult. So we just ignore this extension. - - As a result, the information we provide to the callback is no longer a - verbatim copy of the certificate request payload. In the case of TLS 1.3 - The 'CertificateType' list is synthetically generated from the server's - @signature_algorithms@ extension, and the @signature_algorithms_certs@ - extension is ignored. + , hstCCS13Sent :: Bool + } + deriving (Show) - Since the original TLS 1.2 'CertificateType' has no provision for the newer - certificate types that have appeared in TLS 1.3 we're adding some synthetic - values that have no equivalent values in the TLS 1.2 'CertificateType' as - defined in the IANA - registry. These values are inferred - from the TLS 1.3 @signature_algorithms@ extension, and will allow clients to - present Ed25519 and Ed448 certificates when these become supported. --} +-- | When we receive a CertificateRequest from a server, a just-in-time +-- callback is issued to the application to obtain a suitable certificate. +-- Somewhat unfortunately, the callback parameters don't abstract away the +-- details of the TLS 1.2 Certificate Request message, which combines the +-- legacy @certificate_types@ and new @supported_signature_algorithms@ +-- parameters is a rather subtle way. +-- +-- TLS 1.2 also (again unfortunately, in the opinion of the author of this +-- comment) overloads the signature algorithms parameter to constrain not only +-- the algorithms used in TLS, but also the algorithms used by issuing CAs in +-- the X.509 chain. Best practice is to NOT treat such that restriction as a +-- MUST, but rather take it as merely a preference, when a choice exists. If +-- the best chain available does not match the provided signature algorithm +-- list, go ahead and use it anyway, it will probably work, and the server may +-- not even care about the issuer CAs at all, it may be doing DANE or have +-- explicit mappings for the client's public key, ... +-- +-- The TLS 1.3 @CertificateRequest@ message, drops @certificate_types@ and no +-- longer overloads @supported_signature_algorithms@ to cover X.509. It also +-- includes a new opaque context token that the client must echo back, which +-- makes certain client authentication replay attacks more difficult. We will +-- store that context separately, it does not need to be presented in the user +-- callback. The certificate signature algorithms preferred by the peer are +-- now in the separate @signature_algorithms_cert@ extension, but we cannot +-- report these to the application callback without an API change. The good +-- news is that filtering the X.509 signature types is generally unnecessary, +-- unwise and difficult. So we just ignore this extension. +-- +-- As a result, the information we provide to the callback is no longer a +-- verbatim copy of the certificate request payload. In the case of TLS 1.3 +-- The 'CertificateType' list is synthetically generated from the server's +-- @signature_algorithms@ extension, and the @signature_algorithms_certs@ +-- extension is ignored. +-- +-- Since the original TLS 1.2 'CertificateType' has no provision for the newer +-- certificate types that have appeared in TLS 1.3 we're adding some synthetic +-- values that have no equivalent values in the TLS 1.2 'CertificateType' as +-- defined in the IANA +-- registry. These values are inferred +-- from the TLS 1.3 @signature_algorithms@ extension, and will allow clients to +-- present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata = - ( [CertificateType] - , Maybe [HashAndSignatureAlgorithm] - , [DistinguishedName] ) + ( [CertificateType] + , Maybe [HashAndSignatureAlgorithm] + , [DistinguishedName] + ) -newtype HandshakeM a = HandshakeM { runHandshakeM :: State HandshakeState a } +newtype HandshakeM a = HandshakeM {runHandshakeM :: State HandshakeState a} deriving (Functor, Applicative, Monad) instance MonadState HandshakeState HandshakeM where put x = HandshakeM (put x) - get = HandshakeM get + get = HandshakeM get state f = HandshakeM (state f) -- create a new empty handshake state newEmptyHandshake :: Version -> ClientRandom -> HandshakeState -newEmptyHandshake ver crand = HandshakeState - { hstClientVersion = ver - , hstClientRandom = crand - , hstServerRandom = Nothing - , hstMasterSecret = Nothing - , hstKeyState = HandshakeKeyState Nothing Nothing - , hstServerDHParams = Nothing - , hstDHPrivate = Nothing - , hstServerECDHParams = Nothing - , hstGroupPrivate = Nothing - , hstHandshakeDigest = HandshakeMessages [] - , hstHandshakeMessages = [] - , hstCertReqToken = Nothing - , hstCertReqCBdata = Nothing - , hstCertReqSigAlgsCert = Nothing - , hstClientCertSent = False - , hstCertReqSent = False - , hstClientCertChain = Nothing - , hstPendingTxState = Nothing - , hstPendingRxState = Nothing - , hstPendingCipher = Nothing - , hstPendingCompression = nullCompression - , hstExtendedMasterSec = False - , hstNegotiatedGroup = Nothing - , hstTLS13HandshakeMode = FullHandshake - , hstTLS13RTT0Status = RTT0None - , hstTLS13EarlySecret = Nothing - , hstTLS13ResumptionSecret = Nothing - , hstCCS13Sent = False - } +newEmptyHandshake ver crand = + HandshakeState + { hstClientVersion = ver + , hstClientRandom = crand + , hstServerRandom = Nothing + , hstMainSecret = Nothing + , hstKeyState = HandshakeKeyState Nothing Nothing + , hstServerDHParams = Nothing + , hstDHPrivate = Nothing + , hstServerECDHParams = Nothing + , hstGroupPrivate = Nothing + , hstHandshakeDigest = HandshakeMessages [] + , hstHandshakeMessages = [] + , hstCertReqToken = Nothing + , hstCertReqCBdata = Nothing + , hstCertReqSigAlgsCert = Nothing + , hstClientCertSent = False + , hstCertReqSent = False + , hstClientCertChain = Nothing + , hstPendingTxState = Nothing + , hstPendingRxState = Nothing + , hstPendingCipher = Nothing + , hstPendingCompression = nullCompression + , hstExtendedMainSecret = False + , hstSupportedGroup = Nothing + , hstTLS13HandshakeMode = FullHandshake + , hstTLS13RTT0Status = RTT0None + , hstTLS13EarlySecret = Nothing + , hstTLS13ResumptionSecret = Nothing + , hstCCS13Sent = 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) }) - where setPK hks = hks { hksRemotePublicKey = Just pk } +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) }) - where setKeys hks = hks { hksLocalPublicPrivateKeys = Just keys } +setPublicPrivateKeys keys = modify (\hst -> hst{hstKeyState = setKeys (hstKeyState hst)}) + where + setKeys hks = hks{hksLocalPublicPrivateKeys = Just keys} getRemotePublicKey :: HandshakeM PubKey -getRemotePublicKey = fromJust "remote public key" <$> gets (hksRemotePublicKey . hstKeyState) +getRemotePublicKey = fromJust <$> gets (hksRemotePublicKey . hstKeyState) getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey) -getLocalPublicPrivateKeys = fromJust "local public/private key" <$> gets (hksLocalPublicPrivateKeys . hstKeyState) +getLocalPublicPrivateKeys = + 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 "server DH params" <$> gets hstServerDHParams +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 "server ECDH params" <$> gets hstServerECDHParams +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 "server DH private" <$> gets hstDHPrivate +getDHPrivate = fromJust <$> gets hstDHPrivate getGroupPrivate :: HandshakeM GroupPrivate -getGroupPrivate = fromJust "server ECDH private" <$> gets hstGroupPrivate +getGroupPrivate = fromJust <$> gets hstGroupPrivate setGroupPrivate :: GroupPrivate -> HandshakeM () -setGroupPrivate shp = modify (\hst -> hst { hstGroupPrivate = Just shp }) +setGroupPrivate shp = modify (\hst -> hst{hstGroupPrivate = Just shp}) -setExtendedMasterSec :: Bool -> HandshakeM () -setExtendedMasterSec b = modify (\hst -> hst { hstExtendedMasterSec = b }) +setExtendedMainSecret :: Bool -> HandshakeM () +setExtendedMainSecret b = modify (\hst -> hst{hstExtendedMainSecret = b}) -getExtendedMasterSec :: HandshakeM Bool -getExtendedMasterSec = gets hstExtendedMasterSec +getExtendedMainSecret :: HandshakeM Bool +getExtendedMainSecret = gets hstExtendedMainSecret -setNegotiatedGroup :: Group -> HandshakeM () -setNegotiatedGroup g = modify (\hst -> hst { hstNegotiatedGroup = Just g }) +setSupportedGroup :: Group -> HandshakeM () +setSupportedGroup g = modify (\hst -> hst{hstSupportedGroup = Just g}) -getNegotiatedGroup :: HandshakeM (Maybe Group) -getNegotiatedGroup = gets hstNegotiatedGroup +getSupportedGroup :: HandshakeM (Maybe Group) +getSupportedGroup = gets hstSupportedGroup -- | Type to show which handshake mode is used in TLS 1.3. -data HandshakeMode13 = - -- | Full handshake is used. +data HandshakeMode13 + = -- | Full handshake is used. FullHandshake - -- | Full handshake is used with hello retry request. - | HelloRetryRequest - -- | Server authentication is skipped. - | PreSharedKey - -- | Server authentication is skipped and early data is sent. - | RTT0 - deriving (Show,Eq) + | -- | Full handshake is used with hello retry request. + HelloRetryRequest + | -- | Server authentication is skipped. + PreSharedKey + | -- | Server authentication is skipped and early data is sent. + RTT0 + 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 -data RTT0Status = RTT0None - | RTT0Sent - | RTT0Accepted - | RTT0Rejected - deriving (Show,Eq) +data RTT0Status + = RTT0None + | RTT0Sent + | RTT0Accepted + | RTT0Rejected + 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 setCCS13Sent :: Bool -> HandshakeM () -setCCS13Sent sent = modify (\hst -> hst { hstCCS13Sent = sent }) +setCCS13Sent sent = modify (\hst -> hst{hstCCS13Sent = sent}) getCCS13Sent :: HandshakeM Bool getCCS13Sent = gets hstCCS13Sent 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}) 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 -- getPendingCipher :: HandshakeM Cipher -getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher +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) @@ -378,10 +385,12 @@ 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 } +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 @@ -390,17 +399,19 @@ 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] - } + 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) + let folded = f (hashFinal hashCtx) hashCtx' = hashUpdate (hashInit hashAlg) folded - in hs { hstHandshakeDigest = HandshakeDigestContext hashCtx' - , hstHandshakeMessages = [folded] - } + in hs + { hstHandshakeDigest = HandshakeDigestContext hashCtx' + , hstHandshakeMessages = [folded] + } getSessionHash :: HandshakeM ByteString getSessionHash = gets $ \hst -> @@ -410,110 +421,144 @@ getHandshakeDigest :: Version -> Role -> HandshakeM ByteString getHandshakeDigest ver role = gets gen - where gen hst = case hstHandshakeDigest hst of - HandshakeDigestContext hashCtx -> - let msecret = fromJust "master secret" $ hstMasterSecret hst - cipher = fromJust "cipher" $ hstPendingCipher hst - in generateFinish ver cipher msecret hashCtx - HandshakeMessages _ -> - error "un-initialized handshake digest" - generateFinish | role == ClientRole = generateClientFinished - | otherwise = generateServerFinished + 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 master secret from the pre master secret. -setMasterSecretFromPre :: ByteArrayAccess preMaster - => Version -- ^ chosen transmission version - -> Role -- ^ the role (Client or Server) of the generating side - -> preMaster -- ^ the pre master secret - -> HandshakeM ByteString -setMasterSecretFromPre ver role premasterSecret = do - ems <- getExtendedMasterSec +-- | Generate the main secret from the pre-main secret. +setMainSecretFromPre + :: ByteArrayAccess preMain + => Version + -- ^ chosen transmission version + -> Role + -- ^ the role (Client or Server) of the generating side + -> preMain + -- ^ the pre-main secret + -> HandshakeM ByteString +setMainSecretFromPre ver role preMainSecret = do + ems <- getExtendedMainSecret secret <- if ems then get >>= genExtendedSecret else genSecret <$> get - setMasterSecret ver role secret + setMainSecret ver role secret return secret - where genSecret hst = - generateMasterSecret ver (fromJust "cipher" $ hstPendingCipher hst) - premasterSecret - (hstClientRandom hst) - (fromJust "server random" $ hstServerRandom hst) - genExtendedSecret hst = - generateExtendedMasterSec ver (fromJust "cipher" $ hstPendingCipher hst) - premasterSecret - <$> getSessionHash + where + genSecret hst = + generateMainSecret + ver + (fromJust $ hstPendingCipher hst) + preMainSecret + (hstClientRandom hst) + (fromJust $ hstServerRandom hst) + genExtendedSecret hst = + generateExtendedMainSecret + ver + (fromJust $ hstPendingCipher hst) + preMainSecret + <$> getSessionHash --- | Set master secret and as a side effect generate the key block +-- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state. -setMasterSecret :: Version -> Role -> ByteString -> HandshakeM () -setMasterSecret ver role masterSecret = modify $ \hst -> - let (pendingTx, pendingRx) = computeKeyBlock hst masterSecret ver role - in hst { hstMasterSecret = Just masterSecret +setMainSecret :: Version -> Role -> ByteString -> HandshakeM () +setMainSecret ver role mainSecret = modify $ \hst -> + let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role + in hst + { hstMainSecret = Just mainSecret , hstPendingTxState = Just pendingTx - , hstPendingRxState = Just pendingRx } - -computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) -computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) - where cipher = fromJust "cipher" $ hstPendingCipher hst - keyblockSize = cipherKeyBlockSize cipher + , hstPendingRxState = Just pendingRx + } - bulk = cipherBulk cipher - digestSize = if hasMAC (bulkF bulk) then hashDigestSize (cipherHash cipher) - else 0 - keySize = bulkKeySize bulk - ivSize = bulkIVSize bulk - kb = generateKeyBlock ver cipher (hstClientRandom hst) - (fromJust "server random" $ hstServerRandom hst) - masterSecret keyblockSize +computeKeyBlock + :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) +computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx) + where + cipher = fromJust $ hstPendingCipher hst + keyblockSize = cipherKeyBlockSize cipher - (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = - fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) + bulk = cipherBulk cipher + digestSize = + if hasMAC (bulkF bulk) + then hashDigestSize (cipherHash cipher) + else 0 + keySize = bulkKeySize bulk + ivSize = bulkIVSize bulk + kb = + generateKeyBlock + ver + cipher + (hstClientRandom hst) + (fromJust $ hstServerRandom hst) + mainSecret + keyblockSize - cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey - , cstIV = cWriteIV - , cstMacSecret = cMACSecret } - cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey - , cstIV = sWriteIV - , cstMacSecret = sMACSecret } - msClient = MacState { msSequence = 0 } - msServer = MacState { msSequence = 0 } + (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = + fromJust $ + partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) - pendingTx = RecordState - { stCryptState = if cc == ClientRole then cstClient else cstServer - , stMacState = if cc == ClientRole then msClient else msServer - , stCryptLevel = CryptMasterSecret - , stCipher = Just cipher - , stCompression = hstPendingCompression hst - } - pendingRx = RecordState - { stCryptState = if cc == ClientRole then cstServer else cstClient - , stMacState = if cc == ClientRole then msServer else msClient - , stCryptLevel = CryptMasterSecret - , stCipher = Just cipher - , stCompression = hstPendingCompression hst - } + cstClient = + CryptState + { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey + , cstIV = cWriteIV + , cstMacSecret = cMACSecret + } + cstServer = + CryptState + { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey + , cstIV = sWriteIV + , cstMacSecret = sMACSecret + } + msClient = MacState{msSequence = 0} + msServer = MacState{msSequence = 0} - orOnServer f g = if cc == ClientRole then f else g + pendingTx = + RecordState + { stCryptState = if cc == ClientRole then cstClient else cstServer + , stMacState = if cc == ClientRole then msClient else msServer + , stCryptLevel = CryptMainSecret + , stCipher = Just cipher + , stCompression = hstPendingCompression hst + } + pendingRx = + RecordState + { stCryptState = if cc == ClientRole then cstServer else cstClient + , stMacState = if cc == ClientRole then msServer else msClient + , stCryptLevel = CryptMainSecret + , stCipher = Just cipher + , stCompression = hstPendingCompression hst + } + orOnServer f g = if cc == ClientRole then f else g -setServerHelloParameters :: Version -- ^ chosen version - -> ServerRandom - -> Cipher - -> Compression - -> HandshakeM () +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" + 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 + | ver < TLS12 = SHA1_MD5 | maybe True (< TLS12) (cipherMinVer ciph) = SHA256 - | otherwise = cipherHash ciph + | otherwise = cipherHash ciph diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -1,65 +1,78 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Handshake.State13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Handshake.State13 - ( CryptLevel ( CryptEarlySecret - , CryptHandshakeSecret - , CryptApplicationSecret - ) - , TrafficSecret - , getTxState - , getRxState - , setTxState - , setRxState - , clearTxState - , clearRxState - , setHelloParameters13 - , transcriptHash - , wrapAsMessageHash13 - , PendingAction(..) - , setPendingActions - , popPendingAction - ) where +module Network.TLS.Handshake.State13 ( + CryptLevel ( + CryptEarlySecret, + CryptHandshakeSecret, + CryptApplicationSecret + ), + TrafficSecret, + getTxRecordState, + getRxRecordState, + setTxRecordState, + setRxRecordState, + getTxLevel, + 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.Imports import Network.TLS.Types -import Network.TLS.Util -getTxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) -getTxState ctx = getXState ctx ctxTxState +getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) +getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) -getRxState ctx = getXState ctx ctxRxState +getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) +getRxRecordState ctx = getXState ctx ctxRxRecordState -getXState :: Context - -> (Context -> MVar RecordState) - -> IO (Hash, Cipher, CryptLevel, ByteString) +getXState + :: Context + -> (Context -> MVar RecordState) + -> IO (Hash, Cipher, CryptLevel, ByteString) getXState ctx func = do tx <- readMVar (func ctx) - let Just usedCipher = stCipher tx + let usedCipher = fromJust $ stCipher tx usedHash = cipherHash usedCipher level = stCryptLevel tx secret = cstMacSecret $ stCryptState tx return (usedHash, usedCipher, level, secret) +-- In the case of QUIC, stCipher is Nothing. +-- So, fromJust causes an error. +getTxLevel :: Context -> IO CryptLevel +getTxLevel ctx = getXLevel ctx ctxTxRecordState + +getRxLevel :: Context -> IO CryptLevel +getRxLevel ctx = getXLevel ctx ctxRxRecordState + +getXLevel + :: Context + -> (Context -> MVar RecordState) + -> IO CryptLevel +getXLevel ctx func = do + tx <- readMVar (func ctx) + return $ stCryptLevel tx + class TrafficSecret ty where fromTrafficSecret :: ty -> (CryptLevel, ByteString) @@ -72,71 +85,88 @@ instance HasCryptLevel a => TrafficSecret (ServerTrafficSecret a) where fromTrafficSecret prx@(ServerTrafficSecret s) = (getCryptLevel prx, s) -setTxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () -setTxState = setXState ctxTxState BulkEncrypt +setTxRecordState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () +setTxRecordState = setXState ctxTxRecordState BulkEncrypt -setRxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () -setRxState = setXState ctxRxState BulkDecrypt +setRxRecordState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () +setRxRecordState = setXState ctxRxRecordState BulkDecrypt -setXState :: TrafficSecret ty - => (Context -> MVar RecordState) -> BulkDirection - -> Context -> Hash -> Cipher -> ty - -> IO () +setXState + :: TrafficSecret ty + => (Context -> MVar RecordState) + -> BulkDirection + -> Context + -> Hash + -> Cipher + -> ty + -> IO () setXState func encOrDec ctx h cipher ts = let (lvl, secret) = fromTrafficSecret ts in setXState' func encOrDec ctx h cipher lvl secret -setXState' :: (Context -> MVar RecordState) -> BulkDirection - -> Context -> Hash -> Cipher -> CryptLevel -> ByteString - -> IO () +setXState' + :: (Context -> MVar RecordState) + -> BulkDirection + -> Context + -> Hash + -> Cipher + -> CryptLevel + -> ByteString + -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt) where - bulk = cipherBulk cipher + bulk = cipherBulk cipher keySize = bulkKeySize bulk - ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) + ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) key = hkdfExpandLabel h secret "key" "" keySize - iv = hkdfExpandLabel h secret "iv" "" ivSize - cst = CryptState { - cstKey = bulkInit bulk encOrDec key - , cstIV = iv - , cstMacSecret = secret - } - rt = RecordState { - stCryptState = cst - , stMacState = MacState { msSequence = 0 } - , stCryptLevel = lvl - , stCipher = Just cipher - , stCompression = nullCompression - } + iv = hkdfExpandLabel h secret "iv" "" ivSize + cst = + CryptState + { cstKey = bulkInit bulk encOrDec key + , cstIV = iv + , cstMacSecret = secret + } + rt = + RecordState + { stCryptState = cst + , stMacState = MacState{msSequence = 0} + , stCryptLevel = lvl + , stCipher = Just cipher + , stCompression = nullCompression + } -clearTxState :: Context -> IO () -clearTxState = clearXState ctxTxState +clearTxRecordState :: Context -> IO () +clearTxRecordState = clearXState ctxTxRecordState -clearRxState :: Context -> IO () -clearRxState = clearXState ctxRxState +clearRxRecordState :: Context -> IO () +clearRxRecordState = clearXState ctxRxRecordState clearXState :: (Context -> MVar RecordState) -> Context -> IO () clearXState func ctx = - modifyMVar_ (func ctx) (\rt -> return rt { stCipher = Nothing }) + 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 - } + 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 + | 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 (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 @@ -147,25 +177,27 @@ cipher <- getPendingCipher foldHandshakeDigest (cipherHash cipher) foldFunc where - foldFunc dig = B.concat [ "\254\0\0" - , B.singleton (fromIntegral $ B.length dig) - , dig - ] + 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 "HState" <$> getHState ctx + hst <- fromJust <$> getHState ctx case hstHandshakeDigest hst of - HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx - HandshakeMessages _ -> error "un-initialized handshake digest" + HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx + HandshakeMessages _ -> error "un-initialized handshake digest" -setPendingActions :: Context -> [PendingAction] -> IO () -setPendingActions ctx = writeIORef (ctxPendingActions ctx) +setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () +setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx) -popPendingAction :: Context -> IO (Maybe PendingAction) -popPendingAction ctx = do - let ref = ctxPendingActions ctx +popPendingRecvAction :: Context -> IO (Maybe PendingRecvAction) +popPendingRecvAction ctx = do + let ref = ctxPendingRecvActions ctx actions <- readIORef ref case actions of - bs:bss -> writeIORef ref bss >> return (Just bs) - [] -> return Nothing + bs : bss -> writeIORef ref bss >> return (Just bs) + [] -> return Nothing diff --git a/Network/TLS/Hooks.hs b/Network/TLS/Hooks.hs --- a/Network/TLS/Hooks.hs +++ b/Network/TLS/Hooks.hs @@ -1,21 +1,14 @@ --- | --- Module : Network.TLS.Context --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Hooks - ( Logging(..) - , Hooks(..) - , defaultHooks - ) where +module Network.TLS.Hooks ( + Logging (..), + Hooks (..), + defaultHooks, +) where import qualified Data.ByteString as B -import Network.TLS.Struct (Header, Handshake) +import Data.Default.Class +import Network.TLS.Struct (Handshake, Header) import Network.TLS.Struct13 (Handshake13) import Network.TLS.X509 (CertificateChain) -import Data.Default.Class -- | Hooks for logging -- @@ -23,40 +16,42 @@ data Logging = Logging { loggingPacketSent :: String -> IO () , loggingPacketRecv :: String -> IO () - , loggingIOSent :: B.ByteString -> IO () - , loggingIORecv :: Header -> B.ByteString -> IO () + , loggingIOSent :: B.ByteString -> IO () + , loggingIORecv :: Header -> B.ByteString -> IO () } defaultLogging :: Logging -defaultLogging = Logging - { loggingPacketSent = \_ -> return () - , loggingPacketRecv = \_ -> return () - , loggingIOSent = \_ -> return () - , loggingIORecv = \_ _ -> return () - } +defaultLogging = + Logging + { loggingPacketSent = \_ -> return () + , loggingPacketRecv = \_ -> return () + , loggingIOSent = \_ -> return () + , loggingIORecv = \_ _ -> return () + } instance Default Logging where def = defaultLogging -- | A collection of hooks actions. data Hooks = Hooks - { -- | called at each handshake message received - hookRecvHandshake :: Handshake -> IO Handshake - -- | called at each handshake message received for TLS 1.3 - , hookRecvHandshake13 :: Handshake13 -> IO Handshake13 - -- | called at each certificate chain message received + { hookRecvHandshake :: Handshake -> IO Handshake + -- ^ called at each handshake message received + , hookRecvHandshake13 :: Handshake13 -> IO Handshake13 + -- ^ called at each handshake message received for TLS 1.3 , hookRecvCertificates :: CertificateChain -> IO () - -- | hooks on IO and packets, receiving and sending. - , hookLogging :: Logging + -- ^ called at each certificate chain message received + , hookLogging :: Logging + -- ^ hooks on IO and packets, receiving and sending. } defaultHooks :: Hooks -defaultHooks = Hooks - { hookRecvHandshake = return - , hookRecvHandshake13 = return - , hookRecvCertificates = return . const () - , hookLogging = def - } +defaultHooks = + Hooks + { hookRecvHandshake = return + , hookRecvHandshake13 = return + , hookRecvCertificates = return . const () + , hookLogging = def + } instance Default Hooks where def = defaultHooks diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -1,25 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} --- | --- Module : Network.TLS.IO --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.IO - ( sendPacket - , sendPacket13 - , recvPacket - , recvPacket13 + +module Network.TLS.IO ( + sendPacket12, + sendPacket13, + recvPacket12, + recvPacket13, -- - , isRecvComplete - , checkValid + isRecvComplete, + checkValid, + -- * Grouping multiple packets in the same flight - , PacketFlightM - , runPacketFlight - , loadPacket13 - ) where + PacketFlightM, + runPacketFlight, + loadPacket13, +) where import Control.Exception (finally, throwIO) import Control.Monad.Reader @@ -32,7 +27,6 @@ import Network.TLS.Imports import Network.TLS.Receiving import Network.TLS.Record -import Network.TLS.Record.Layer import Network.TLS.Sending import Network.TLS.State import Network.TLS.Struct @@ -41,91 +35,99 @@ ---------------------------------------------------------------- -- | Send one packet to the context -sendPacket :: Context -> Packet -> IO () -sendPacket ctx@Context{ctxRecordLayer = recordLayer} pkt = do +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. when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $ - writePacketBytes ctx recordLayer (AppData B.empty) >>= - recordSendBytes recordLayer + writePacketBytes12 ctx recordLayer (AppData B.empty) + >>= recordSendBytes recordLayer ctx - writePacketBytes ctx recordLayer pkt >>= recordSendBytes recordLayer - where isNonNullAppData (AppData b) = not $ B.null b - isNonNullAppData _ = False + writePacketBytes12 ctx recordLayer pkt >>= recordSendBytes recordLayer ctx + where + isNonNullAppData (AppData b) = not $ B.null b + isNonNullAppData _ = False -writePacketBytes :: Monoid bytes - => Context -> RecordLayer bytes -> Packet -> IO bytes -writePacketBytes ctx recordLayer pkt = do +writePacketBytes12 + :: Monoid bytes + => Context + -> RecordLayer bytes + -> Packet + -> IO bytes +writePacketBytes12 ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) - edataToSend <- encodePacket ctx recordLayer pkt + edataToSend <- encodePacket12 ctx recordLayer pkt either throwCore return edataToSend ---------------------------------------------------------------- sendPacket13 :: Context -> Packet13 -> IO () sendPacket13 ctx@Context{ctxRecordLayer = recordLayer} pkt = - writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer + writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer ctx -writePacketBytes13 :: Monoid bytes - => Context -> RecordLayer bytes -> Packet13 -> IO bytes +writePacketBytes13 + :: Monoid bytes + => Context + -> RecordLayer bytes + -> Packet13 + -> IO bytes writePacketBytes13 ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) edataToSend <- encodePacket13 ctx recordLayer pkt either throwCore return edataToSend ---------------------------------------------------------------- + -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed -recvPacket :: Context -> IO (Either TLSError Packet) -recvPacket ctx@Context{ctxRecordLayer = recordLayer} = do - compatSSLv2 <- ctxHasSSLv2ClientHello ctx - hrr <- usingState_ ctx getTLS13HRR +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 compatSSLv2 appDataOverhead + erecord <- recordRecv recordLayer ctx appDataOverhead case erecord of - Left err -> return $ Left err + Left err -> return $ Left err Right record -> - if hrr && isCCS record then - recvPacket ctx - else do - pktRecv <- processPacket ctx record - if isEmptyHandshake pktRecv then - -- When a handshake record is fragmented we continue - -- receiving in order to feed stHandshakeRecordCont - recvPacket ctx - else do - pkt <- case pktRecv of - Right (Handshake hss) -> - ctxWithHooks ctx $ \hooks -> - Right . Handshake <$> mapM (hookRecvHandshake hooks) hss - _ -> return pktRecv - case pkt of - Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p - _ -> return () - when compatSSLv2 $ ctxDisableSSLv2ClientHello ctx - return pkt + if hrr && isCCS record + then recvPacket12 ctx + else do + pktRecv <- processPacket 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 isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True -isCCS _ = False +isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool isEmptyHandshake (Right (Handshake [])) = True -isEmptyHandshake _ = False +isEmptyHandshake _ = False ---------------------------------------------------------------- recvPacket13 :: Context -> IO (Either TLSError Packet13) recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do - erecord <- recordRecv13 recordLayer + erecord <- recordRecv13 recordLayer ctx case erecord of Left err@(Error_Protocol _ BadRecordMac) -> do -- If the server decides to reject RTT0 data but accepts RTT1 @@ -133,30 +135,31 @@ 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 + | 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 + 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 + 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 + _ -> return pktRecv + case pkt of + Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p + _ -> return () + return pkt isEmptyHandshake13 :: Either TLSError Packet13 -> Bool isEmptyHandshake13 (Right (Handshake13 [])) = True -isEmptyHandshake13 _ = False +isEmptyHandshake13 _ = False ---------------------------------------------------------------- @@ -164,7 +167,7 @@ isRecvComplete ctx = usingState_ ctx $ do cont <- gets stHandshakeRecordCont cont13 <- gets stHandshakeRecordCont13 - return $! isNothing cont && isNothing cont13 + return $ isNothing cont && isNothing cont13 checkValid :: Context -> IO () checkValid ctx = do @@ -182,19 +185,21 @@ -- immediately, update the context digest and transcript, but actual sending is -- deferred. Packets are sent all at once when the monadic computation ends -- (normal termination but also if interrupted by an exception). -newtype PacketFlightM b a = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a) +newtype PacketFlightM b a + = PacketFlightM (ReaderT (RecordLayer b, IORef (Builder b)) IO a) deriving (Functor, Applicative, Monad, MonadFail, MonadIO) -runPacketFlight :: Context -> (forall b . Monoid b => PacketFlightM b a) -> IO a -runPacketFlight Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do +runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a +runPacketFlight ctx@Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do ref <- newIORef id - runReaderT f (recordLayer, ref) `finally` sendPendingFlight recordLayer ref + runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref -sendPendingFlight :: Monoid b => RecordLayer b -> IORef (Builder b) -> IO () -sendPendingFlight recordLayer ref = do +sendPendingFlight + :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO () +sendPendingFlight ctx recordLayer ref = do build <- readIORef ref let bss = build [] - unless (null bss) $ recordSendBytes recordLayer $ mconcat bss + unless (null bss) $ recordSendBytes recordLayer ctx $ mconcat bss loadPacket13 :: Monoid b => Context -> Packet13 -> PacketFlightM b () loadPacket13 ctx pkt = PacketFlightM $ do diff --git a/Network/TLS/Imports.hs b/Network/TLS/Imports.hs --- a/Network/TLS/Imports.hs +++ b/Network/TLS/Imports.hs @@ -1,60 +1,38 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} --- | --- Module : Network.TLS.Imports --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Imports - ( +module Network.TLS.Imports ( -- generic exports - ByteString - , (<&>) - , module Control.Applicative - , module Control.Monad -#if !MIN_VERSION_base(4,13,0) - , MonadFail -#endif - , module Data.Bits - , module Data.List - , module Data.Maybe - , module Data.Semigroup - , module Data.Ord - , module Data.Word + ByteString, + (<&>), + module Control.Applicative, + module Control.Monad, + module Data.Bits, + module Data.List, + module Data.Maybe, + module Data.Semigroup, + module Data.Ord, + module Data.Word, -- project definition - , showBytesHex - ) where + showBytesHex, +) where import Data.ByteString (ByteString) -import Data.ByteString.Char8 () -- instance -#if MIN_VERSION_base(4,11,0) +import Data.ByteString.Char8 () + +-- instance import Data.Functor -#endif import Control.Applicative import Control.Monad -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail (MonadFail) -#endif import Data.Bits import Data.List -import Data.Maybe hiding (fromJust) -import Data.Semigroup +import Data.Maybe import Data.Ord +import Data.Semigroup import Data.Word import Data.ByteArray.Encoding as B import qualified Prelude as P -#if !MIN_VERSION_base(4,11,0) -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = P.flip fmap -infixl 1 <&> -#endif - showBytesHex :: ByteString -> P.String showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString) - diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -1,28 +1,24 @@ {-# OPTIONS_HADDOCK hide #-} --- | --- Module : Network.TLS.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Internal - ( module Network.TLS.Struct - , module Network.TLS.Struct13 - , module Network.TLS.Packet - , module Network.TLS.Packet13 - , module Network.TLS.Receiving - , module Network.TLS.Sending - , module Network.TLS.Wire - , sendPacket - , recvPacket - ) where -import Network.TLS.Struct -import Network.TLS.Struct13 +module Network.TLS.Internal ( + module Network.TLS.Struct, + module Network.TLS.Struct13, + module Network.TLS.Packet, + module Network.TLS.Packet13, + module Network.TLS.Receiving, + module Network.TLS.Sending, + module Network.TLS.Types, + module Network.TLS.Wire, + sendPacket12, + recvPacket12, +) where + +import Network.TLS.Core (recvPacket12, sendPacket12) 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.Core (sendPacket, recvPacket) diff --git a/Network/TLS/KeySchedule.hs b/Network/TLS/KeySchedule.hs --- a/Network/TLS/KeySchedule.hs +++ b/Network/TLS/KeySchedule.hs @@ -1,35 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.KeySchedule --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.KeySchedule - ( hkdfExtract - , hkdfExpandLabel - , deriveSecret - ) where +module Network.TLS.KeySchedule ( + hkdfExtract, + hkdfExpandLabel, + deriveSecret, +) where + import qualified Crypto.Hash as H import Crypto.KDF.HKDF import Data.ByteArray (convert) import qualified Data.ByteString as BS import Network.TLS.Crypto -import Network.TLS.Wire import Network.TLS.Imports +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 SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) +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) hkdfExtract SHA512 salt ikm = convert (extract salt ikm :: PRK H.SHA512) -hkdfExtract _ _ _ = error "hkdfExtract: unsupported hash" +hkdfExtract _ _ _ = error "hkdfExtract: unsupported hash" ---------------------------------------------------------------- @@ -43,12 +37,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 - -> ByteString - -> ByteString - -> Int - -> ByteString +hkdfExpandLabel + :: Hash + -> ByteString + -> ByteString + -> ByteString + -> Int + -> ByteString hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do @@ -57,7 +52,7 @@ putOpaque8 ctx expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString -expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len +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 expand' SHA512 secret label len = expand (extractSkip secret :: PRK H.SHA512) label len diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -1,62 +1,59 @@ --- | --- Module : Network.TLS.MAC --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.MAC - ( macSSL - , hmac - , prf_MD5 - , prf_SHA1 - , prf_SHA256 - , prf_TLS - , prf_MD5SHA1 - ) where +module Network.TLS.MAC ( + macSSL, + hmac, + prf_MD5, + prf_SHA1, + prf_SHA256, + prf_TLS, + prf_MD5SHA1, +) where -import Network.TLS.Crypto -import Network.TLS.Types -import Network.TLS.Imports import qualified Data.ByteArray as B (xor) import qualified Data.ByteString as B +import Network.TLS.Crypto +import Network.TLS.Imports +import Network.TLS.Types type HMAC = ByteString -> ByteString -> ByteString macSSL :: Hash -> HMAC macSSL alg secret msg = - f $! B.concat - [ secret - , B.replicate padLen 0x5c - , f $! B.concat [ secret, B.replicate padLen 0x36, msg ] - ] + f $ + B.concat + [ secret + , B.replicate padLen 0x5c + , f $ B.concat [secret, B.replicate padLen 0x36, msg] + ] where padLen = case alg of - MD5 -> 48 + MD5 -> 48 SHA1 -> 40 - _ -> error ("internal error: macSSL called with " ++ show alg) + _ -> 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) - where opad = B.map (xor 0x5c) k' - ipad = B.map (xor 0x36) k' +hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg) + where + opad = B.map (xor 0x5c) k' + ipad = B.map (xor 0x36) k' - f = hash alg - bl = hashBlockSize alg + f = hash alg + bl = hashBlockSize alg - k' = B.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 + k' = B.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 -hmacIter :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] +hmacIter + :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString] 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 - if digestsize >= len - then [ B.take (fromIntegral len) out ] - else out : hmacIter f secret seed an (len - digestsize) + let an = f secret aprev + in let out = f secret (B.concat [an, seed]) + in let digestsize = B.length out + in if digestsize >= len + then [B.take (fromIntegral len) out] + else out : hmacIter f secret seed an (len - digestsize) prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len @@ -67,9 +64,10 @@ prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString prf_MD5SHA1 secret seed len = B.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 + where + slen = B.length secret + s1 = B.take (slen `div` 2 + slen `mod` 2) secret + s2 = B.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 diff --git a/Network/TLS/Measurement.hs b/Network/TLS/Measurement.hs --- a/Network/TLS/Measurement.hs +++ b/Network/TLS/Measurement.hs @@ -1,46 +1,44 @@ --- | --- Module : Network.TLS.Measurement --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Measurement - ( Measurement(..) - , newMeasurement - , addBytesReceived - , addBytesSent - , resetBytesCounters - , incrementNbHandshakes - ) where +module Network.TLS.Measurement ( + Measurement (..), + newMeasurement, + addBytesReceived, + addBytesSent, + resetBytesCounters, + incrementNbHandshakes, +) where import Network.TLS.Imports -- | record some data about this connection. data Measurement = Measurement - { nbHandshakes :: !Word32 -- ^ number of handshakes on this context - , bytesReceived :: !Word32 -- ^ bytes received since last handshake - , bytesSent :: !Word32 -- ^ bytes sent since last handshake - } deriving (Show,Eq) + { nbHandshakes :: Word32 + -- ^ number of handshakes on this context + , bytesReceived :: Word32 + -- ^ bytes received since last handshake + , bytesSent :: Word32 + -- ^ bytes sent since last handshake + } + deriving (Show, Eq) newMeasurement :: Measurement -newMeasurement = Measurement - { nbHandshakes = 0 +newMeasurement = + Measurement + { nbHandshakes = 0 , bytesReceived = 0 - , bytesSent = 0 + , bytesSent = 0 } addBytesReceived :: Int -> Measurement -> Measurement addBytesReceived sz measure = - measure { bytesReceived = bytesReceived measure + fromIntegral sz } + measure{bytesReceived = bytesReceived measure + fromIntegral sz} addBytesSent :: Int -> Measurement -> Measurement addBytesSent sz measure = - measure { bytesSent = bytesSent measure + fromIntegral sz } + measure{bytesSent = bytesSent measure + fromIntegral sz} resetBytesCounters :: Measurement -> Measurement -resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 } +resetBytesCounters measure = measure{bytesReceived = 0, bytesSent = 0} incrementNbHandshakes :: Measurement -> Measurement incrementNbHandshakes measure = - measure { nbHandshakes = nbHandshakes measure + 1 } + measure{nbHandshakes = nbHandshakes measure + 1} diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -1,249 +1,192 @@ {-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Packet --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the Packet module contains everything necessary to serialize and deserialize things --- with only explicit parameters, no TLS state is involved here. --- -module Network.TLS.Packet - ( +{-# LANGUAGE RecordWildCards #-} + +-- | The Packet module contains everything necessary to serialize and +-- deserialize things with only explicit parameters, no TLS state is +-- involved here. +module Network.TLS.Packet ( -- * params for encoding and decoding - CurrentParams(..) + CurrentParams (..), + -- * marshall functions for header messages - , decodeHeader - , decodeDeprecatedHeaderLength - , decodeDeprecatedHeader - , encodeHeader - , encodeHeaderNoVer -- use for SSL3 + decodeHeader, + encodeHeader, -- * marshall functions for alert messages - , decodeAlert - , decodeAlerts - , encodeAlerts + decodeAlert, + decodeAlerts, + encodeAlerts, -- * marshall functions for handshake messages - , decodeHandshakeRecord - , decodeHandshake - , decodeDeprecatedHandshake - , encodeHandshake - , encodeHandshakeHeader - , encodeHandshakeContent + decodeHandshakeRecord, + decodeHandshake, + encodeHandshake, + encodeCertificate, -- * marshall functions for change cipher spec message - , decodeChangeCipherSpec - , encodeChangeCipherSpec - - , decodePreMasterSecret - , encodePreMasterSecret - , encodeSignedDHParams - , encodeSignedECDHParams - - , decodeReallyServerKeyXchgAlgorithmData + decodeChangeCipherSpec, + encodeChangeCipherSpec, + decodePreMainSecret, + encodePreMainSecret, + encodeSignedDHParams, + encodeSignedECDHParams, + decodeReallyServerKeyXchgAlgorithmData, -- * generate things for packet content - , generateMasterSecret - , generateExtendedMasterSec - , generateKeyBlock - , generateClientFinished - , generateServerFinished - - , generateCertificateVerify_SSL - , generateCertificateVerify_SSL_DSS + generateMainSecret, + generateExtendedMainSecret, + generateKeyBlock, + generateClientFinished, + generateServerFinished, -- * for extensions parsing - , getSignatureHashAlgorithm - , putSignatureHashAlgorithm - , getBinaryVersion - , putBinaryVersion - , getClientRandom32 - , putClientRandom32 - , getServerRandom32 - , putServerRandom32 - , getExtensions - , putExtension - , getSession - , putSession - , putDNames - , getDNames - ) where + getSignatureHashAlgorithm, + putSignatureHashAlgorithm, + getBinaryVersion, + putBinaryVersion, + getClientRandom32, + putClientRandom32, + getServerRandom32, + putServerRandom32, + getExtensions, + putExtension, + getSession, + putSession, + putDNames, + getDNames, + getHandshakeType, +) where -import Network.TLS.Imports -import Network.TLS.Struct -import Network.TLS.Wire -import Network.TLS.Cap -import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as B (convert) +import qualified Data.ByteString as B +import Data.X509 ( + CertificateChain, + CertificateChainRaw (..), + decodeCertificateChain, + encodeCertificateChain, + ) +import Network.TLS.Cipher (Cipher (..), CipherKeyExchangeType (..)) import Network.TLS.Crypto +import Network.TLS.Imports import Network.TLS.MAC -import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..)) +import Network.TLS.Struct import Network.TLS.Util.ASN1 -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteArray as B (convert) +import Network.TLS.Wire data CurrentParams = CurrentParams - { cParamsVersion :: Version -- ^ current protocol version - , cParamsKeyXchgType :: Maybe CipherKeyExchangeType -- ^ current key exchange type - } deriving (Show,Eq) + { cParamsVersion :: Version + -- ^ current protocol version + , cParamsKeyXchgType :: Maybe CipherKeyExchangeType + -- ^ current key exchange type + } + deriving (Show, Eq) {- marshall helpers -} -getVersion :: Get Version -getVersion = do - major <- getWord8 - minor <- getWord8 - case verOfNum (major, minor) of - Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) - Just v -> return v - -getBinaryVersion :: Get (Maybe Version) -getBinaryVersion = do - major <- getWord8 - minor <- getWord8 - return $ verOfNum (major, minor) +getBinaryVersion :: Get Version +getBinaryVersion = Version <$> getWord16 putBinaryVersion :: Version -> Put -putBinaryVersion ver = putWord8 major >> putWord8 minor - where (major, minor) = numericalVer ver +putBinaryVersion (Version ver) = putWord16 ver getHeaderType :: Get ProtocolType -getHeaderType = do - ty <- getWord8 - case valToType ty of - Nothing -> fail ("invalid header type: " ++ show ty) - Just t -> return t +getHeaderType = ProtocolType <$> getWord8 putHeaderType :: ProtocolType -> Put -putHeaderType = putWord8 . valOfType +putHeaderType (ProtocolType pt) = putWord8 pt getHandshakeType :: Get HandshakeType -getHandshakeType = do - ty <- getWord8 - case valToType ty of - Nothing -> fail ("invalid handshake type: " ++ show ty) - Just t -> return t +getHandshakeType = HandshakeType <$> getWord8 {- - decode and encode headers -} decodeHeader :: ByteString -> Either TLSError Header -decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getVersion <*> getWord16 - -decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 -decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16 - -decodeDeprecatedHeader :: Word16 -> ByteString -> Either TLSError Header -decodeDeprecatedHeader size = - runGetErr "deprecatedheader" $ do - 1 <- getWord8 - version <- getVersion - return $ Header ProtocolType_DeprecatedHandshake version size +decodeHeader = + runGetErr "header" $ Header <$> getHeaderType <*> getBinaryVersion <*> getWord16 encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) - {- FIXME check len <= 2^14 -} -encodeHeaderNoVer :: Header -> ByteString -encodeHeaderNoVer (Header pt _ len) = runPut (putHeaderType pt >> putWord16 len) - {- FIXME check len <= 2^14 -} +{- FIXME check len <= 2^14 -} {- - decode and encode ALERT -} decodeAlert :: Get (AlertLevel, AlertDescription) decodeAlert = do - al <- getWord8 - ad <- getWord8 - case (valToType al, valToType ad) of - (Just a, Just d) -> return (a, d) - (Nothing, _) -> fail "cannot decode alert level" - (_, Nothing) -> fail "cannot decode alert description" + al <- AlertLevel <$> getWord8 + ad <- AlertDescription <$> getWord8 + return (al, ad) decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)] decodeAlerts = runGetErr "alerts" loop - where loop = do - r <- remaining - if r == 0 - then return [] - else (:) <$> decodeAlert <*> loop + where + loop = do + r <- remaining + if r == 0 + then return [] + else (:) <$> decodeAlert <*> loop encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString encodeAlerts l = runPut $ mapM_ encodeAlert l - where encodeAlert (al, ad) = putWord8 (valOfType al) >> putWord8 (valOfType ad) + where + encodeAlert (al, ad) = putWord8 (fromAlertLevel al) >> putWord8 (fromAlertDescription ad) {- decode and encode HANDSHAKE -} decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do - ty <- getHandshakeType + ty <- getHandshakeType content <- getOpaque24 return (ty, content) -decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake +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 -> decodeCertificates - HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp - HandshakeType_CertRequest -> decodeCertRequest cp + 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 - -decodeDeprecatedHandshake :: ByteString -> Either TLSError Handshake -decodeDeprecatedHandshake b = runGetErr "deprecatedhandshake" getDeprecated b - where getDeprecated = do - 1 <- getWord8 - ver <- getVersion - cipherSpecLen <- fromEnum <$> getWord16 - sessionIdLen <- fromEnum <$> getWord16 - challengeLen <- fromEnum <$> getWord16 - ciphers <- getCipherSpec cipherSpecLen - session <- getSessionId sessionIdLen - random <- getChallenge challengeLen - let compressions = [0] - return $ ClientHello ver random session ciphers compressions [] (Just b) - getCipherSpec len | len < 3 = return [] - getCipherSpec len = do - [c0,c1,c2] <- map fromEnum <$> replicateM 3 getWord8 - ([ toEnum $ c1 * 0x100 + c2 | c0 == 0 ] ++) <$> getCipherSpec (len - 3) - getSessionId 0 = return $ Session Nothing - getSessionId len = Session . Just <$> getBytes len - getChallenge len | 32 < len = getBytes (len - 32) >> getChallenge 32 - getChallenge len = ClientRandom . B.append (B.replicate (32 - len) 0) <$> getBytes len + HandshakeType_CertVerify -> decodeCertVerify cp + HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp + HandshakeType_Finished -> decodeFinished + HandshakeType_NewSessionTicket -> decodeNewSessionTicket + x -> fail $ "Unsupported HandshakeType " ++ show x decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest decodeClientHello :: Get Handshake decodeClientHello = do - ver <- getVersion - random <- getClientRandom32 - session <- getSession - ciphers <- getWords16 + ver <- getBinaryVersion + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 compressions <- getWords8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 + r <- remaining + exts <- + if r > 0 then fromIntegral <$> getWord16 >>= getExtensions else do - rest <- remaining - _ <- getBytes rest - return [] - return $ ClientHello ver random session ciphers compressions exts Nothing + rest <- remaining + _ <- getBytes rest + return [] + let ch = CH session ciphers exts + return $ ClientHello ver random compressions ch decodeServerHello :: Get Handshake decodeServerHello = do - ver <- getVersion - random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 + ver <- getBinaryVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 compressionid <- getWord8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 + r <- remaining + exts <- + if r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts @@ -251,26 +194,31 @@ decodeServerHelloDone :: Get Handshake decodeServerHelloDone = return ServerHelloDone -decodeCertificates :: Get Handshake -decodeCertificates = do - certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) +decodeCertificate :: Get Handshake +decodeCertificate = do + certsRaw <- + CertificateChainRaw + <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) case decodeCertificateChain certsRaw of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) - Right cc -> return $ Certificates cc - where getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) + Right cc -> return $ Certificate 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 - mcertTypes <- map (valToType . fromIntegral) <$> getWords8 - certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes - sigHashAlgs <- if cParamsVersion cp >= TLS12 - then Just <$> (getWord16 >>= getSignatureHashAlgorithms) - else return Nothing +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)) + where + getSignatureHashAlgorithms len = + getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) -- | Decode a list CA distinguished names getDNames :: Get [DistinguishedName] @@ -283,26 +231,29 @@ getDName = do dName <- getOpaque16 when (B.length dName == 0) $ fail "certrequest: invalid DN length" - dn <- either fail return $ decodeASN1Object "cert request DistinguishedName" dName + 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) +decodeClientKeyXchg cp = + -- case ClientKeyXchg <$> (remaining >>= getBytes) case cParamsKeyXchgType cp of - Nothing -> error "no client key exchange type" + 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_DSS = 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 + 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 @@ -311,68 +262,66 @@ -- decodeServerKeyXchg_ECDH :: Get ServerECDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams -decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus - <*> getInteger16 -- exponent +decodeServerKeyXchg_RSA = + ServerRSAParams + <$> getInteger16 -- modulus + <*> getInteger16 -- exponent -decodeServerKeyXchgAlgorithmData :: Version - -> CipherKeyExchangeType - -> Get ServerKeyXchgAlgorithmData +decodeServerKeyXchgAlgorithmData + :: Version + -> CipherKeyExchangeType + -> Get ServerKeyXchgAlgorithmData decodeServerKeyXchgAlgorithmData ver cke = toCKE - where toCKE = case cke of - CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA - CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH - CipherKeyExchange_DHE_RSA -> do - dhparams <- getServerDHParams - signature <- getDigitallySigned ver - return $ SKX_DHE_RSA dhparams signature - CipherKeyExchange_DHE_DSS -> do - dhparams <- getServerDHParams - signature <- getDigitallySigned ver - return $ SKX_DHE_DSS dhparams signature - CipherKeyExchange_ECDHE_RSA -> do - ecdhparams <- getServerECDHParams - signature <- getDigitallySigned ver - return $ SKX_ECDHE_RSA ecdhparams signature - CipherKeyExchange_ECDHE_ECDSA -> do - ecdhparams <- getServerECDHParams - signature <- getDigitallySigned ver - return $ SKX_ECDHE_ECDSA ecdhparams signature - _ -> do - bs <- remaining >>= getBytes - return $ SKX_Unknown bs + where + toCKE = case cke of + CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA + CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH + CipherKeyExchange_DHE_RSA -> do + dhparams <- getServerDHParams + signature <- getDigitallySigned ver + return $ SKX_DHE_RSA dhparams signature + CipherKeyExchange_DHE_DSA -> do + dhparams <- getServerDHParams + signature <- getDigitallySigned ver + return $ SKX_DHE_DSA dhparams signature + CipherKeyExchange_ECDHE_RSA -> do + ecdhparams <- getServerECDHParams + signature <- getDigitallySigned ver + return $ SKX_ECDHE_RSA ecdhparams signature + CipherKeyExchange_ECDHE_ECDSA -> do + ecdhparams <- getServerECDHParams + signature <- getDigitallySigned ver + return $ SKX_ECDHE_ECDSA ecdhparams signature + _ -> do + bs <- remaining >>= getBytes + return $ SKX_Unknown bs decodeServerKeyXchg :: CurrentParams -> Get Handshake decodeServerKeyXchg cp = case cParamsKeyXchgType cp of Just cke -> ServerKeyXchg <$> decodeServerKeyXchgAlgorithmData (cParamsVersion cp) cke - Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) + Nothing -> ServerKeyXchg . SKX_Unparsed <$> (remaining >>= getBytes) encodeHandshake :: Handshake -> ByteString encodeHandshake o = - let content = runPut $ encodeHandshakeContent o in - let len = B.length content in - let header = case o of - ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message - _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in - B.concat [ header, content ] + let content = encodeHandshake' o + in let len = B.length content + in let header = runPut $ encodeHandshakeHeader (typeOfHandshake o) len + in B.concat [header, content] encodeHandshakeHeader :: HandshakeType -> Int -> Put -encodeHandshakeHeader ty len = putWord8 (valOfType ty) >> putWord24 len - -encodeHandshakeContent :: Handshake -> Put +encodeHandshakeHeader ty len = putWord8 (fromHandshakeType ty) >> putWord24 len -encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do - putBytes deprecated -encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do +encodeHandshake' :: Handshake -> ByteString +encodeHandshake' (ClientHello version random compressionIDs CH{..}) = runPut $ do putBinaryVersion version putClientRandom32 random - putSession session - putWords16 cipherIDs + putSession chSession + putWords16 chCiphers putWords8 compressionIDs - putExtensions exts + putExtensions chExtensions return () - -encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do +encodeHandshake' (ServerHello version random session cipherid compressionID exts) = runPut $ do putBinaryVersion version putServerRandom32 random putSession session @@ -380,40 +329,38 @@ putWord8 compressionID putExtensions exts return () - -encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) - where (CertificateChainRaw certs) = encodeCertificateChain cc - -encodeHandshakeContent (ClientKeyXchg ckx) = do +encodeHandshake' (Certificate cc) = encodeCertificate cc +encodeHandshake' (ClientKeyXchg ckx) = runPut $ do case ckx of - CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster - CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic - CKX_ECDH bytes -> putOpaque8 bytes - -encodeHandshakeContent (ServerKeyXchg skg) = + CKX_RSA encryptedPreMain -> putBytes encryptedPreMain + CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic + CKX_ECDH bytes -> putOpaque8 bytes +encodeHandshake' (ServerKeyXchg skg) = runPut $ case skg of - SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" - SKX_DH_Anon params -> putServerDHParams params + SKX_RSA _ -> error "encodeHandshake' SKX_RSA not implemented" + SKX_DH_Anon params -> putServerDHParams params SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig - SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig + SKX_DHE_DSA params sig -> putServerDHParams params >> putDigitallySigned sig SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_ECDHE_ECDSA params sig -> putServerECDHParams params >> putDigitallySigned sig - SKX_Unparsed bytes -> putBytes bytes - _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) - -encodeHandshakeContent HelloRequest = return () -encodeHandshakeContent ServerHelloDone = return () - -encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do - putWords8 (map valOfType certTypes) - case sigAlgs of - Nothing -> return () - Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l + SKX_Unparsed bytes -> putBytes bytes + _ -> + error ("encodeHandshake': cannot handle: " ++ show skg) +encodeHandshake' HelloRequest = "" +encodeHandshake' ServerHelloDone = "" +encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do + putWords8 (map fromCertificateType certTypes) + putWords16 $ + map + ( \(HashAlgorithm x, SignatureAlgorithm y) -> fromIntegral x * 256 + fromIntegral y + ) + sigAlgs putDNames certAuthorities - -encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned - -encodeHandshakeContent (Finished opaque) = putBytes opaque +encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned +encodeHandshake' (Finished opaque) = runPut $ putBytes opaque +encodeHandshake' (NewSessionTicket life ticket) = runPut $ do + putWord32 life + putOpaque16 ticket ------------------------------------------------------------ @@ -423,7 +370,7 @@ enc <- mapM encodeCA dnames let totLength = sum $ map ((+) 2 . B.length) enc putWord16 (fromIntegral totLength) - mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc + mapM_ (\b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc where -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1Object dn @@ -451,24 +398,24 @@ getSession = do len8 <- getWord8 case fromIntegral len8 of - 0 -> return $ Session Nothing + 0 -> return $ Session Nothing len -> Session . Just <$> getBytes len putSession :: Session -> Put -putSession (Session Nothing) = putWord8 0 +putSession (Session Nothing) = putWord8 0 putSession (Session (Just s)) = putOpaque8 s getExtensions :: Int -> Get [ExtensionRaw] -getExtensions 0 = return [] +getExtensions 0 = return [] getExtensions len = do - extty <- getWord16 + extty <- ExtensionID <$> getWord16 extdatalen <- getWord16 extdata <- getBytes $ fromIntegral extdatalen extxs <- getExtensions (len - fromIntegral extdatalen - 4) return $ ExtensionRaw extty extdata : extxs putExtension :: ExtensionRaw -> Put -putExtension (ExtensionRaw ty l) = putWord16 ty >> putOpaque16 l +putExtension (ExtensionRaw (ExtensionID ty) l) = putWord16 ty >> putOpaque16 l putExtensions :: [ExtensionRaw] -> Put putExtensions [] = return () @@ -476,53 +423,51 @@ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do - h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" - s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" - return (h,s) + h <- HashAlgorithm <$> getWord8 + s <- SignatureAlgorithm <$> getWord8 + return (h, s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put -putSignatureHashAlgorithm (h,s) = - putWord8 (valOfType h) >> putWord8 (valOfType s) +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] +putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p, g, y] -- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8 case curveType of - 3 -> do -- ECParameters ECCurveType: curve name type - mgrp <- toEnumSafe16 <$> getWord16 -- ECParameters NamedCurve - case mgrp of - Nothing -> error "getServerECDHParams: unknown group" - Just grp -> do - mxy <- getOpaque8 -- ECPoint - case decodeGroupPublic grp mxy of - Left e -> error $ "getServerECDHParams: " ++ show e - Right grppub -> return $ ServerECDHParams grp grppub + 3 -> do + -- ECParameters ECCurveType: curve name type + grp <- Group <$> getWord16 -- ECParameters NamedCurve + mxy <- getOpaque8 -- ECPoint + case decodeGroupPublic grp mxy of + Left e -> error $ "getServerECDHParams: " ++ show e + Right grppub -> return $ ServerECDHParams grp grppub _ -> error "getServerECDHParams: unknown type for ECDH Params" -- RFC 4492 Section 5.4 Server Key Exchange putServerECDHParams :: ServerECDHParams -> Put -putServerECDHParams (ServerECDHParams grp grppub) = do - putWord8 3 -- ECParameters ECCurveType - putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve +putServerECDHParams (ServerECDHParams (Group grp) grppub) = do + putWord8 3 -- ECParameters ECCurveType + putWord16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint getDigitallySigned :: Version -> Get DigitallySigned -getDigitallySigned ver - | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) - <*> getOpaque16 - | otherwise = DigitallySigned Nothing <$> getOpaque16 +getDigitallySigned _ver = + DigitallySigned + <$> getSignatureHashAlgorithm + <*> getOpaque16 putDigitallySigned :: DigitallySigned -> Put -putDigitallySigned (DigitallySigned mhash sig) = - maybe (return ()) putSignatureHashAlgorithm mhash >> putOpaque16 sig +putDigitallySigned (DigitallySigned h sig) = + putSignatureHashAlgorithm h >> putOpaque16 sig {- - decode and encode ALERT @@ -536,25 +481,28 @@ encodeChangeCipherSpec :: ByteString encodeChangeCipherSpec = runPut (putWord8 1) --- rsa pre master secret -decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) -decodePreMasterSecret = runGetErr "pre-master-secret" $ - (,) <$> getVersion <*> getBytes 46 +-- RSA pre-main secret +decodePreMainSecret :: ByteString -> Either TLSError (Version, ByteString) +decodePreMainSecret = + runGetErr "pre-main-secret" $ + (,) <$> getBinaryVersion <*> getBytes 46 -encodePreMasterSecret :: Version -> ByteString -> ByteString -encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) +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 + :: Version + -> CipherKeyExchangeType + -> ByteString + -> Either TLSError ServerKeyXchgAlgorithmData decodeReallyServerKeyXchgAlgorithmData ver cke = - runGetErr "server-key-xchg-algorithm-data" (decodeServerKeyXchgAlgorithmData ver cke) - + runGetErr + "server-key-xchg-algorithm-data" + (decodeServerKeyXchgAlgorithmData ver cke) {- - generate things for packet content @@ -569,118 +517,96 @@ | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256 | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph -generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString -generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) = - B.concat $ map computeMD5 ["A","BB","CCC"] - where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] - computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] - -generateMasterSecret_TLS :: ByteArrayAccess preMaster => PRF -> preMaster -> ClientRandom -> ServerRandom -> ByteString -generateMasterSecret_TLS prf premasterSecret (ClientRandom c) (ServerRandom s) = - prf (B.convert premasterSecret) seed 48 - where seed = B.concat [ "master secret", c, s ] - -generateMasterSecret :: ByteArrayAccess preMaster - => Version - -> Cipher - -> preMaster - -> ClientRandom - -> ServerRandom - -> ByteString -generateMasterSecret SSL2 _ = generateMasterSecret_SSL -generateMasterSecret SSL3 _ = generateMasterSecret_SSL -generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c +generateMainSecret_TLS + :: ByteArrayAccess preMain + => PRF + -> preMain + -> ClientRandom + -> ServerRandom + -> ByteString +generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) = + prf (B.convert preMainSecret) seed 48 + where + seed = B.concat ["master secret", c, s] -generateExtendedMasterSec :: ByteArrayAccess preMaster - => Version - -> Cipher - -> preMaster - -> ByteString - -> ByteString -generateExtendedMasterSec v c premasterSecret sessionHash = - getPRF v c (B.convert premasterSecret) seed 48 - where seed = B.append "extended master secret" sessionHash +generateMainSecret + :: ByteArrayAccess preMain + => Version + -> Cipher + -> preMain + -> ClientRandom + -> ServerRandom + -> ByteString +generateMainSecret v c = generateMainSecret_TLS $ getPRF v c -generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString -generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mastersecret kbsize = - prf mastersecret seed kbsize where seed = B.concat [ "key expansion", s, c ] +generateExtendedMainSecret + :: ByteArrayAccess preMain + => Version + -> Cipher + -> preMain + -> ByteString + -> ByteString +generateExtendedMainSecret v c preMainSecret sessionHash = + getPRF v c (B.convert preMainSecret) seed 48 + where + seed = B.append "extended master secret" sessionHash -generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString -generateKeyBlock_SSL (ClientRandom c) (ServerRandom s) mastersecret kbsize = - B.concat $ map computeMD5 $ take ((kbsize `div` 16) + 1) labels - where labels = [ uncurry BC.replicate x | x <- zip [1..] ['A'..'Z'] ] - computeMD5 label = hash MD5 $ B.concat [ mastersecret, computeSHA1 label ] - computeSHA1 label = hash SHA1 $ B.concat [ label, mastersecret, s, c ] +generateKeyBlock_TLS + :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString +generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize = + prf mainSecret seed kbsize + where + seed = B.concat ["key expansion", s, c] -generateKeyBlock :: Version - -> Cipher - -> ClientRandom - -> ServerRandom - -> ByteString - -> Int - -> ByteString -generateKeyBlock SSL2 _ = generateKeyBlock_SSL -generateKeyBlock SSL3 _ = generateKeyBlock_SSL -generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c +generateKeyBlock + :: Version + -> Cipher + -> ClientRandom + -> ServerRandom + -> ByteString + -> Int + -> ByteString +generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c generateFinished_TLS :: PRF -> ByteString -> ByteString -> HashCtx -> ByteString -generateFinished_TLS prf label mastersecret hashctx = prf mastersecret seed 12 - where seed = B.concat [ label, hashFinal hashctx ] - -generateFinished_SSL :: ByteString -> ByteString -> HashCtx -> ByteString -generateFinished_SSL sender mastersecret hashctx = B.concat [md5hash, sha1hash] - where md5hash = hash MD5 $ B.concat [ mastersecret, pad2, md5left ] - sha1hash = hash SHA1 $ B.concat [ mastersecret, B.take 40 pad2, sha1left ] - - lefthash = hashFinal $ flip hashUpdateSSL (pad1, B.take 40 pad1) - $ foldl hashUpdate hashctx [sender,mastersecret] - (md5left,sha1left) = B.splitAt 16 lefthash - pad2 = B.replicate 48 0x5c - pad1 = B.replicate 48 0x36 - -generateClientFinished :: Version - -> Cipher - -> ByteString - -> HashCtx - -> ByteString -generateClientFinished ver ciph - | ver < TLS10 = generateFinished_SSL "CLNT" - | otherwise = generateFinished_TLS (getPRF ver ciph) "client finished" - -generateServerFinished :: Version - -> Cipher - -> ByteString - -> HashCtx - -> ByteString -generateServerFinished ver ciph - | ver < TLS10 = generateFinished_SSL "SRVR" - | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" - -{- returns *output* after final MD5/SHA1 -} -generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString -generateCertificateVerify_SSL = generateFinished_SSL "" +generateFinished_TLS prf label mainSecret hashctx = prf mainSecret seed 12 + where + seed = B.concat [label, hashFinal hashctx] -{- returns *input* before final SHA1 -} -generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString -generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash - where toHash = B.concat [ mastersecret, pad2, sha1left ] +generateClientFinished + :: Version + -> Cipher + -> ByteString + -> HashCtx + -> ByteString +generateClientFinished ver ciph = + generateFinished_TLS (getPRF ver ciph) "client finished" - sha1left = hashFinal $ flip hashUpdate pad1 - $ hashUpdate hashctx mastersecret - pad2 = B.replicate 40 0x5c - pad1 = B.replicate 40 0x36 +generateServerFinished + :: Version + -> Cipher + -> ByteString + -> HashCtx + -> ByteString +generateServerFinished ver ciph = + generateFinished_TLS (getPRF ver ciph) "server finished" -encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString -encodeSignedDHParams dhparams cran sran = runPut $ - putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams +encodeSignedDHParams + :: ServerDHParams -> ClientRandom -> ServerRandom -> ByteString +encodeSignedDHParams dhparams cran sran = + runPut $ + putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams -- Combination of RFC 5246 and 4492 is ambiguous. -- Let's assume ecdhe_rsa and ecdhe_dss are identical to -- dhe_rsa and dhe_dss. -encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString -encodeSignedECDHParams dhparams cran sran = runPut $ - putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams +encodeSignedECDHParams + :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString +encodeSignedECDHParams dhparams cran sran = + runPut $ + putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams -fromJustM :: MonadFail m => String -> Maybe a -> m a -fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing") -fromJustM _ (Just x) = return x +encodeCertificate :: CertificateChain -> ByteString +encodeCertificate cc = runPut $ putOpaque24 (runPut $ mapM_ putOpaque24 certs) + where + (CertificateChainRaw certs) = encodeCertificateChain cc diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -1,52 +1,43 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Network.TLS.Packet13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Packet13 - ( encodeHandshake13 - , getHandshakeType13 - , decodeHandshakeRecord13 - , decodeHandshake13 - , decodeHandshakes13 - ) where +module Network.TLS.Packet13 ( + encodeHandshake13, + decodeHandshakeRecord13, + decodeHandshake13, + decodeHandshakes13, + encodeCertificate13, +) where import qualified Data.ByteString as B +import Data.X509 ( + CertificateChain, + CertificateChainRaw (..), + decodeCertificateChain, + encodeCertificateChain, + ) +import Network.TLS.ErrT +import Network.TLS.Imports +import Network.TLS.Packet import Network.TLS.Struct import Network.TLS.Struct13 -import Network.TLS.Packet +import Network.TLS.Types import Network.TLS.Wire -import Network.TLS.Imports -import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) -import Network.TLS.ErrT encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt where - !tp = typeOfHandshake13 hdsk - !content = encodeHandshake13' hdsk - !len = B.length content - !header = encodeHandshakeHeader13 tp len - !pkt = B.concat [header, content] + tp = typeOfHandshake13 hdsk + content = encodeHandshake13' hdsk + len = B.length content + header = encodeHandshakeHeader13 tp len + pkt = B.concat [header, content] -- TLS 1.3 does not use "select (extensions_present)". putExtensions :: [ExtensionRaw] -> Put putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es) encodeHandshake13' :: Handshake13 -> ByteString -encodeHandshake13' (ClientHello13 version random session cipherIDs exts) = runPut $ do - putBinaryVersion version - putClientRandom32 random - putSession session - putWords16 cipherIDs - putWords8 [0] - putExtensions exts encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do putBinaryVersion TLS12 putServerRandom32 random @@ -58,14 +49,7 @@ encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do putOpaque8 reqctx putExtensions exts -encodeHandshake13' (Certificate13 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 +encodeHandshake13' (Certificate13 reqctx cc ess) = encodeCertificate13 reqctx cc ess encodeHandshake13' (CertVerify13 hs signature) = runPut $ do putSignatureHashAlgorithm hs putOpaque16 signature @@ -78,78 +62,62 @@ putExtensions exts encodeHandshake13' EndOfEarlyData13 = "" encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 -encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1 +encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1 -encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString +encodeHandshakeHeader13 :: HandshakeType -> Int -> ByteString encodeHandshakeHeader13 ty len = runPut $ do - putWord8 (valOfType ty) + putWord8 (fromHandshakeType ty) putWord24 len decodeHandshakes13 :: MonadError TLSError m => ByteString -> m [Handshake13] decodeHandshakes13 bs = case decodeHandshakeRecord13 bs of - GotError err -> throwError err - GotPartial _cont -> error "decodeHandshakes13" - GotSuccess (ty,content) -> case decodeHandshake13 ty content of - Left e -> throwError e - Right h -> return [h] - GotSuccessRemaining (ty,content) left -> case decodeHandshake13 ty content of - Left e -> throwError e - Right h -> (h:) <$> decodeHandshakes13 left - -{- decode and encode HANDSHAKE -} -getHandshakeType13 :: Get HandshakeType13 -getHandshakeType13 = do - ty <- getWord8 - case valToType ty of - Nothing -> fail ("invalid handshake type: " ++ show ty) - Just t -> return t + GotError err -> throwError err + GotPartial _cont -> error "decodeHandshakes13" + GotSuccess (ty, content) -> case decodeHandshake13 ty content of + Left e -> throwError e + Right h -> return [h] + GotSuccessRemaining (ty, content) left -> case decodeHandshake13 ty content of + Left e -> throwError e + Right h -> (h :) <$> decodeHandshakes13 left -decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString) +decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do - ty <- getHandshakeType13 + ty <- getHandshakeType content <- getOpaque24 return (ty, content) -decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 +decodeHandshake13 + :: HandshakeType -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of - HandshakeType_ClientHello13 -> decodeClientHello13 - HandshakeType_ServerHello13 -> decodeServerHello13 - HandshakeType_Finished13 -> decodeFinished13 - HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13 - HandshakeType_CertRequest13 -> decodeCertRequest13 - HandshakeType_Certificate13 -> decodeCertificate13 - HandshakeType_CertVerify13 -> decodeCertVerify13 - HandshakeType_NewSessionTicket13 -> decodeNewSessionTicket13 - HandshakeType_EndOfEarlyData13 -> return EndOfEarlyData13 - HandshakeType_KeyUpdate13 -> decodeKeyUpdate13 - -decodeClientHello13 :: Get Handshake13 -decodeClientHello13 = do - Just ver <- getBinaryVersion - random <- getClientRandom32 - session <- getSession - ciphers <- getWords16 - _comp <- getWords8 - exts <- fromIntegral <$> getWord16 >>= getExtensions - return $ ClientHello13 ver random session ciphers exts + 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 x) -> fail $ "Unsupported HandshakeType " ++ show x decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do - Just _ver <- getBinaryVersion - random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 - _comp <- getWord8 - exts <- fromIntegral <$> getWord16 >>= getExtensions + _ver <- getBinaryVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 + _comp <- getWord8 + exts <- fromIntegral <$> getWord16 >>= getExtensions return $ ServerHello13 random session cipherid exts decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 <$> (remaining >>= getBytes) decodeEncryptedExtensions13 :: Get Handshake13 -decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do - len <- fromIntegral <$> getWord16 - getExtensions len +decodeEncryptedExtensions13 = + EncryptedExtensions13 <$> do + len <- fromIntegral <$> getWord16 + getExtensions len decodeCertRequest13 :: Get Handshake13 decodeCertRequest13 = do @@ -165,7 +133,7 @@ (certRaws, ess) <- unzip <$> getList len getCert case decodeCertificateChain $ CertificateChainRaw certRaws of Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) - Right cc -> return $ Certificate13 reqctx cc ess + Right cc -> return $ Certificate13 reqctx cc ess where getCert = do l <- fromIntegral <$> getWord24 @@ -179,12 +147,12 @@ decodeNewSessionTicket13 :: Get Handshake13 decodeNewSessionTicket13 = do - life <- getWord32 + life <- getWord32 ageadd <- getWord32 - nonce <- getOpaque8 - label <- getOpaque16 - len <- fromIntegral <$> getWord16 - exts <- getExtensions len + nonce <- getOpaque8 + label <- getOpaque16 + len <- fromIntegral <$> getWord16 + exts <- getExtensions len return $ NewSessionTicket13 life ageadd nonce label exts decodeKeyUpdate13 :: Get Handshake13 @@ -194,3 +162,14 @@ 0 -> return $ KeyUpdate13 UpdateNotRequested 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) + where + CertificateChainRaw certs = encodeCertificateChain cc + putCert (certRaw, exts) = do + putOpaque24 certRaw + putExtensions exts diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -1,634 +1,633 @@ --- | --- Module : Network.TLS.Parameters --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Parameters - ( - ClientParams(..) - , ServerParams(..) - , CommonParams - , DebugParams(..) - , ClientHooks(..) - , OnCertificateRequest - , OnServerCertificate - , ServerHooks(..) - , Supported(..) - , Shared(..) - -- * special default - , defaultParamsClient - -- * Parameters - , MaxFragmentEnum(..) - , EMSMode(..) - , GroupUsage(..) - , CertificateUsage(..) - , CertificateRejectReason(..) - ) where - -import Network.TLS.Extension -import Network.TLS.Struct -import qualified Network.TLS.Struct as Struct -import Network.TLS.Session -import Network.TLS.Cipher -import Network.TLS.Measurement -import Network.TLS.Compression -import Network.TLS.Crypto -import Network.TLS.Credentials -import Network.TLS.X509 -import Network.TLS.RNG (Seed) -import Network.TLS.Imports -import Network.TLS.Types (HostName) -import Data.Default.Class -import qualified Data.ByteString as B - - -type CommonParams = (Supported, Shared, DebugParams) - --- | All settings should not be used in production -data DebugParams = DebugParams - { - -- | Disable the true randomness in favor of deterministic seed that will produce - -- a deterministic random from. This is useful for tests and debugging purpose. - -- Do not use in production - -- - -- Default: 'Nothing' - debugSeed :: Maybe Seed - -- | Add a way to print the seed that was randomly generated. re-using the same seed - -- will reproduce the same randomness with 'debugSeed' - -- - -- Default: no printing - , debugPrintSeed :: Seed -> IO () - -- | Force to choose this version in the server side. - -- - -- Default: 'Nothing' - , debugVersionForced :: Maybe Version - -- | Printing master keys. - -- - -- Default: no printing - , debugKeyLogger :: String -> IO () - } - -defaultDebugParams :: DebugParams -defaultDebugParams = DebugParams - { debugSeed = Nothing - , debugPrintSeed = const (return ()) - , debugVersionForced = Nothing - , debugKeyLogger = \_ -> return () - } - -instance Show DebugParams where - show _ = "DebugParams" -instance Default DebugParams where - def = defaultDebugParams - -data ClientParams = ClientParams - { -- | - -- - -- Default: 'Nothing' - clientUseMaxFragmentLength :: Maybe MaxFragmentEnum - -- | 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 - -- infrastructure. - -- - -- This value is typically set by 'defaultParamsClient'. - , clientServerIdentification :: (HostName, ByteString) - -- | 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' - , clientUseServerNameIndication :: Bool - -- | try to establish a connection using this session. - -- - -- Default: 'Nothing' - , clientWantSessionResume :: Maybe (SessionID, SessionData) - -- | See the default value of 'Shared'. - , clientShared :: Shared - -- | See the default value of 'ClientHooks'. - , clientHooks :: ClientHooks - -- | 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'. - , clientSupported :: Supported - -- | See the default value of 'DebugParams'. - , clientDebug :: DebugParams - -- | Client tries to send this early data in TLS 1.3 if possible. - -- If not accepted by the server, it is application's responsibility - -- to re-sent it. - -- - -- Default: 'Nothing' - , clientEarlyData :: Maybe ByteString - } deriving (Show) - -defaultParamsClient :: HostName -> ByteString -> ClientParams -defaultParamsClient serverName serverId = ClientParams - { clientUseMaxFragmentLength = Nothing - , clientServerIdentification = (serverName, serverId) - , clientUseServerNameIndication = True - , clientWantSessionResume = Nothing - , clientShared = def - , clientHooks = def - , clientSupported = def - , clientDebug = defaultDebugParams - , clientEarlyData = Nothing - } - -data ServerParams = ServerParams - { -- | Request a certificate from client. - -- - -- Default: 'False' - serverWantClientCert :: Bool - - -- | 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: '[]' - , serverCACertificates :: [SignedCertificate] - - -- | 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 - -- 'Crypto.PubKey.DH.generateParams'. - -- - -- Default: 'Nothing' - , serverDHEParams :: Maybe DHParams - -- | See the default value of 'ServerHooks'. - , serverHooks :: ServerHooks - -- | See the default value of 'Shared'. - , serverShared :: Shared - -- | See the default value of 'Supported'. - , serverSupported :: Supported - -- | See the default value of 'DebugParams'. - , serverDebug :: DebugParams - -- | 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 - , serverEarlyDataSize :: Int - -- | Lifetime in seconds for session tickets generated by the server. - -- Acceptable value range is 0 to 604800 (7 days). The default lifetime - -- is 86400 seconds (1 day). - -- - -- Default: 86400 (one day) - , serverTicketLifetime :: Int - } deriving (Show) - -defaultParamsServer :: ServerParams -defaultParamsServer = ServerParams - { serverWantClientCert = False - , serverCACertificates = [] - , serverDHEParams = Nothing - , serverHooks = def - , serverShared = def - , serverSupported = def - , serverDebug = defaultDebugParams - , serverEarlyDataSize = 0 - , serverTicketLifetime = 86400 - } - -instance Default ServerParams where - def = defaultParamsServer - --- | List all the supported algorithms, versions, ciphers, etc supported. -data Supported = Supported - { - -- | Supported versions by this context. On the client side, the highest - -- version will be used to establish the connection. On the server side, - -- the highest version that is less or equal than the client version will - -- be chosen. - -- - -- Versions should be listed in preference order, i.e. higher versions - -- first. - -- - -- Default: @[TLS13,TLS12,TLS11,TLS10]@ - supportedVersions :: [Version] - -- | Supported cipher methods. The default is empty, specify a suitable - -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often - -- a good choice. - -- - -- Default: @[]@ - , supportedCiphers :: [Cipher] - -- | 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. - -- - -- Default: @[nullCompression]@ - , supportedCompressions :: [Compression] - -- | All supported hash/signature algorithms pair for client - -- 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'. - -- - -- 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, DSS. - -- - -- Default: - -- - -- @ - -- [ (HashIntrinsic, SignatureEd448) - -- , (HashIntrinsic, SignatureEd25519) - -- , (Struct.HashSHA256, SignatureECDSA) - -- , (Struct.HashSHA384, SignatureECDSA) - -- , (Struct.HashSHA512, SignatureECDSA) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA512) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA384) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA256) - -- , (Struct.HashSHA512, SignatureRSA) - -- , (Struct.HashSHA384, SignatureRSA) - -- , (Struct.HashSHA256, SignatureRSA) - -- , (Struct.HashSHA1, SignatureRSA) - -- , (Struct.HashSHA1, SignatureDSS) - -- ] - -- @ - , supportedHashSignatures :: [HashAndSignatureAlgorithm] - -- | 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' - , supportedSecureRenegotiation :: 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. - -- - -- Default: 'False' - , supportedClientInitiatedRenegotiation :: Bool - -- | The mode regarding extended master secret. Enabling this extension - -- provides better security for TLS versions 1.0 to 1.2. TLS 1.3 provides - -- the security properties natively and does not need the extension. - -- - -- By default the extension is enabled but not required. If mode is set - -- to 'RequireEMS', the handshake will fail when the peer does not support - -- the extension. It is also advised to disable SSLv3 which does not have - -- this mechanism. - -- - -- Default: 'AllowEMS' - , supportedExtendedMasterSec :: EMSMode - -- | Set if we support session. - -- - -- Default: 'True' - , supportedSession :: Bool - -- | Support for fallback SCSV defined in RFC7507. - -- If 'True', servers reject handshakes which suggest - -- a lower protocol than the highest protocol supported. - -- - -- Default: 'True' - , supportedFallbackScsv :: 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. - -- - -- Default: 'True' - , supportedEmptyPacket :: Bool - -- | A list of supported elliptic curves and finite-field groups in the - -- 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. - -- - -- The default value includes all groups with security strength of 128 - -- bits or more. - -- - -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ - , supportedGroups :: [Group] - } deriving (Show,Eq) - --- | Client or server policy regarding Extended Master Secret -data EMSMode - = NoEMS -- ^ Extended Master Secret is not used - | AllowEMS -- ^ Extended Master Secret is allowed - | RequireEMS -- ^ Extended Master Secret is required - deriving (Show,Eq) - -defaultSupported :: Supported -defaultSupported = Supported - { supportedVersions = [TLS13,TLS12,TLS11,TLS10] - , supportedCiphers = [] - , supportedCompressions = [nullCompression] - , supportedHashSignatures = [ (HashIntrinsic, SignatureEd448) - , (HashIntrinsic, SignatureEd25519) - , (Struct.HashSHA256, SignatureECDSA) - , (Struct.HashSHA384, SignatureECDSA) - , (Struct.HashSHA512, SignatureECDSA) - , (HashIntrinsic, SignatureRSApssRSAeSHA512) - , (HashIntrinsic, SignatureRSApssRSAeSHA384) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) - , (Struct.HashSHA512, SignatureRSA) - , (Struct.HashSHA384, SignatureRSA) - , (Struct.HashSHA256, SignatureRSA) - , (Struct.HashSHA1, SignatureRSA) - , (Struct.HashSHA1, SignatureDSS) - ] - , supportedSecureRenegotiation = True - , supportedClientInitiatedRenegotiation = False - , supportedExtendedMasterSec = AllowEMS - , supportedSession = True - , supportedFallbackScsv = True - , supportedEmptyPacket = True - , supportedGroups = [X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521] - } - -instance Default Supported where - def = defaultSupported - --- | Parameters that are common to clients and servers. -data Shared = Shared - { -- | 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. - -- - -- Default: 'mempty' - sharedCredentials :: Credentials - -- | Callbacks used by clients and servers in order to resume TLS - -- sessions. The default implementation never resumes sessions. Package - -- - -- provides an in-memory implementation. - -- - -- Default: 'noSessionManager' - , sharedSessionManager :: SessionManager - -- | 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 - -- - -- gives access to a default certificate store configured in the - -- system. - -- - -- Default: 'mempty' - , sharedCAStore :: CertificateStore - -- | 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. - -- - -- See the default value of 'ValidationCache'. - , sharedValidationCache :: ValidationCache - -- | 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. - -- - -- Default: @[]@ - , sharedHelloExtensions :: [ExtensionRaw] - } - -instance Show Shared where - show _ = "Shared" -instance Default Shared where - def = Shared - { sharedCredentials = mempty - , sharedSessionManager = noSessionManager - , sharedCAStore = mempty - , sharedValidationCache = def - , sharedHelloExtensions = [] - } - --- | Group usage callback possible return values. -data GroupUsage = - GroupUsageValid -- ^ usage of group accepted - | GroupUsageInsecure -- ^ usage of group provides insufficient security - | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string) - | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value - deriving (Show,Eq) - -defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage -defaultGroupUsage minBits params public - | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime" - | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator" - | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic - -- To prevent Logjam attack - | dhParamsGetBits params < minBits = return GroupUsageInsecure - | otherwise = return GroupUsageValid - --- | Type for 'onCertificateRequest'. This type synonym is to make --- document readable. -type OnCertificateRequest = ([CertificateType], - Maybe [HashAndSignatureAlgorithm], - [DistinguishedName]) - -> IO (Maybe (CertificateChain, PrivKey)) - --- | Type for 'onServerCertificate'. This type synonym is to make --- document readable. -type OnServerCertificate = CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason] - --- | A set of callbacks run by the clients for various corners of TLS establishment -data ClientHooks = ClientHooks - { -- | 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. - -- - -- 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. - -- - -- 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 - -- - -- 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. - -- - -- 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. - -- - -- Default: returns 'Nothing' anyway. - onCertificateRequest :: OnCertificateRequest - -- | 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. - -- - -- Default: 'validateDefault' - , onServerCertificate :: OnServerCertificate - -- | This action is called when the client sends ClientHello - -- to determine ALPN values such as '["h2", "http/1.1"]'. - -- - -- Default: returns 'Nothing' - , onSuggestALPN :: IO (Maybe [B.ByteString]) - -- | 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. - -- - -- 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. - , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage - } - -defaultClientHooks :: ClientHooks -defaultClientHooks = ClientHooks - { onCertificateRequest = \ _ -> return Nothing - , onServerCertificate = validateDefault - , onSuggestALPN = return Nothing - , onCustomFFDHEGroup = defaultGroupUsage 1024 - } - -instance Show ClientHooks where - show _ = "ClientHooks" -instance Default ClientHooks where - def = defaultClientHooks - --- | A set of callbacks run by the server for various corners of the TLS establishment -data ServerHooks = ServerHooks - { - -- | 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. - -- - -- Default: returns the followings: - -- - -- @ - -- CertificateUsageReject (CertificateRejectOther "no client certificates expected") - -- @ - onClientCertificate :: CertificateChain -> IO CertificateUsage - - -- | 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' - , onUnverifiedClientCert :: IO Bool - - -- | 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) - -- - -- The client cipher list cannot be empty. - -- - -- Default: taking the head of ciphers. - , onCipherChoosing :: Version -> [Cipher] -> Cipher - - -- | 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. - -- - -- Returned credentials may be ignored if a client does not support - -- the signature algorithms used in the certificate chain. - -- - -- Default: returns 'mempty' - , onServerNameIndication :: Maybe HostName -> IO Credentials - - -- | At each new handshake, we call this hook to see if we allow handshake to happens. - -- - -- Default: returns 'True' - , onNewHandshake :: Measurement -> IO Bool - - -- | 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. - -- - -- Default: 'Nothing' - , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) - -- | Allow to modify extensions to be sent in EncryptedExtensions - -- of TLS 1.3. - -- - -- Default: 'return . id' - , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw] - } - -defaultServerHooks :: ServerHooks -defaultServerHooks = ServerHooks - { onClientCertificate = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected" - , onUnverifiedClientCert = return False - , onCipherChoosing = \_ -> head - , onServerNameIndication = \_ -> return mempty - , onNewHandshake = \_ -> return True - , onALPNClientSuggest = Nothing - , onEncryptedExtensionsCreating = return . id - } +module Network.TLS.Parameters ( + ClientParams (..), + ServerParams (..), + CommonParams, + DebugParams (..), + ClientHooks (..), + OnCertificateRequest, + OnServerCertificate, + ServerHooks (..), + Supported (..), + Shared (..), + + -- * special default + defaultParamsClient, + + -- * Parameters + MaxFragmentEnum (..), + EMSMode (..), + GroupUsage (..), + CertificateUsage (..), + CertificateRejectReason (..), +) where + +import qualified Data.ByteString as B +import Data.Default.Class +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Credentials +import Network.TLS.Crypto +import Network.TLS.Extension +import Network.TLS.Imports +import Network.TLS.Measurement +import Network.TLS.RNG (Seed) +import Network.TLS.Session +import Network.TLS.Struct +import qualified Network.TLS.Struct as Struct +import Network.TLS.Types (HostName) +import Network.TLS.X509 + +type CommonParams = (Supported, Shared, DebugParams) + +-- | All settings should not be used in production +data DebugParams = DebugParams + { debugSeed :: Maybe Seed + -- ^ Disable the true randomness in favor of deterministic seed that will produce + -- a deterministic random from. This is useful for tests and debugging purpose. + -- Do not use in production + -- + -- Default: 'Nothing' + , debugPrintSeed :: Seed -> IO () + -- ^ Add a way to print the seed that was randomly generated. re-using the same seed + -- will reproduce the same randomness with 'debugSeed' + -- + -- Default: no printing + , debugVersionForced :: Maybe Version + -- ^ Force to choose this version in the server side. + -- + -- Default: 'Nothing' + , debugKeyLogger :: String -> IO () + -- ^ Printing main keys. + -- + -- Default: no printing + } + +defaultDebugParams :: DebugParams +defaultDebugParams = + DebugParams + { debugSeed = Nothing + , debugPrintSeed = const (return ()) + , debugVersionForced = Nothing + , debugKeyLogger = \_ -> return () + } + +instance Show DebugParams where + show _ = "DebugParams" +instance Default DebugParams where + def = defaultDebugParams + +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. + -- + -- 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 + -- CNAME aliasing (e.g. web virtual host). + -- + -- Default: 'True' + , clientWantSessionResume :: Maybe (SessionID, SessionData) + -- ^ try to establish a connection using this session. + -- + -- Default: 'Nothing' + , 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. + -- + -- 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. + -- + -- Default: 'False' + } + deriving (Show) + +defaultParamsClient :: HostName -> ByteString -> ClientParams +defaultParamsClient serverName serverId = + ClientParams + { clientUseMaxFragmentLength = Nothing + , clientServerIdentification = (serverName, serverId) + , clientUseServerNameIndication = True + , clientWantSessionResume = Nothing + , clientShared = def + , clientHooks = def + , clientSupported = def + , clientDebug = defaultDebugParams + , clientUseEarlyData = False + } + +data ServerParams = ServerParams + { serverWantClientCert :: Bool + -- ^ Request a certificate from client. + -- + -- 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. + -- + -- 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. + -- + -- Value can be one of the standardized groups from module + -- "Network.TLS.Extra.FFDHE" or custom parameters generated with + -- 'Crypto.PubKey.DH.generateParams'. + -- + -- Default: 'Nothing' + , serverHooks :: ServerHooks + -- ^ See the default value of 'ServerHooks'. + , serverShared :: Shared + -- ^ See the default value of 'Shared'. + , serverSupported :: Supported + -- ^ See the default value of 'Supported'. + , 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. + -- + -- Default: 0 + , serverTicketLifetime :: Int + -- ^ Lifetime in seconds for session tickets generated by the server. + -- Acceptable value range is 0 to 604800 (7 days). + -- + -- Default: 7200 (2 hours) + } + deriving (Show) + +defaultParamsServer :: ServerParams +defaultParamsServer = + ServerParams + { serverWantClientCert = False + , serverCACertificates = [] + , serverDHEParams = Nothing + , serverHooks = def + , serverShared = def + , serverSupported = def + , serverDebug = defaultDebugParams + , serverEarlyDataSize = 0 + , serverTicketLifetime = 7200 + } + +instance Default ServerParams where + def = defaultParamsServer + +-- | 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. + -- + -- Versions should be listed in preference 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. + -- + -- 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. + -- + -- Default: @[nullCompression]@ + , supportedHashSignatures :: [HashAndSignatureAlgorithm] + -- ^ All supported hash/signature algorithms pair for client + -- 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'. + -- + -- 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. + -- + -- Default: + -- + -- @ + -- [ (HashIntrinsic, SignatureEd448) + -- , (HashIntrinsic, SignatureEd25519) + -- , (Struct.HashSHA256, SignatureECDSA) + -- , (Struct.HashSHA384, SignatureECDSA) + -- , (Struct.HashSHA512, SignatureECDSA) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA512) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA384) + -- , (HashIntrinsic, SignatureRSApssRSAeSHA256) + -- , (Struct.HashSHA512, SignatureRSA) + -- , (Struct.HashSHA384, SignatureRSA) + -- , (Struct.HashSHA256, SignatureRSA) + -- , (Struct.HashSHA1, SignatureRSA) + -- , (Struct.HashSHA1, SignatureDSA) + -- ] + -- @ + , 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. + -- + -- 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. + -- + -- 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 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. + -- + -- 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. + -- + -- Default: 'True' + , supportedGroups :: [Group] + -- ^ A list of supported elliptic curves and finite-field groups in the + -- 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. + -- + -- The default value includes all groups with security strength of 128 + -- bits or more. + -- + -- Default: @[X25519,X448,P256,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@ + } + deriving (Show, Eq) + +-- | Client or server policy regarding Extended Main Secret +data EMSMode + = -- | Extended Main Secret is not used + NoEMS + | -- | Extended Main Secret is allowed + AllowEMS + | -- | Extended Main Secret is required + RequireEMS + deriving (Show, Eq) + +defaultSupported :: Supported +defaultSupported = + Supported + { supportedVersions = [TLS13, TLS12] + , supportedCiphers = [] + , supportedCompressions = [nullCompression] + , supportedHashSignatures = Struct.supportedSignatureSchemes + , supportedSecureRenegotiation = True + , supportedClientInitiatedRenegotiation = False + , supportedExtendedMainSecret = RequireEMS + , supportedSession = True + , supportedFallbackScsv = True + , supportedEmptyPacket = True + , supportedGroups = supportedNamedGroups + } + +instance Default Supported where + def = defaultSupported + +-- | 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. + -- + -- When credential list is left empty (the default value), no key + -- exchange can take place. + -- + -- Default: 'mempty' + , sharedSessionManager :: SessionManager + -- ^ Callbacks used by clients and servers in order to resume TLS + -- sessions. The default implementation never resumes sessions. Package + -- + -- 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 + -- + -- 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. + -- + -- 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. + -- + -- Default: @[]@ + } + +instance Show Shared where + show _ = "Shared" +instance Default Shared where + def = + Shared + { sharedCredentials = mempty + , sharedSessionManager = noSessionManager + , sharedCAStore = mempty + , sharedValidationCache = def + , sharedHelloExtensions = [] + } + +-- | Group usage callback possible return values. +data GroupUsage + = -- | usage of group accepted + GroupUsageValid + | -- | usage of group provides insufficient security + GroupUsageInsecure + | -- | usage of group rejected for other reason (specified as string) + GroupUsageUnsupported String + | -- | usage of group with an invalid public value + GroupUsageInvalidPublic + deriving (Show, Eq) + +defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage +defaultGroupUsage minBits params public + | even $ dhParamsGetP params = + return $ GroupUsageUnsupported "invalid odd prime" + | not $ dhValid params (dhParamsGetG params) = + return $ GroupUsageUnsupported "invalid generator" + | not $ dhValid params (dhUnwrapPublic public) = + return GroupUsageInvalidPublic + -- To prevent Logjam attack + | dhParamsGetBits params < minBits = return GroupUsageInsecure + | otherwise = return GroupUsageValid + +-- | Type for 'onCertificateRequest'. This type synonym is to make +-- document readable. +type OnCertificateRequest = + ( [CertificateType] + , Maybe [HashAndSignatureAlgorithm] + , [DistinguishedName] + ) + -> IO (Maybe (CertificateChain, PrivKey)) + +-- | Type for 'onServerCertificate'. This type synonym is to make +-- document readable. +type OnServerCertificate = + CertificateStore + -> ValidationCache + -> ServiceID + -> CertificateChain + -> IO [FailedReason] + +-- | A set of callbacks run by the clients for various corners of TLS establishment +data ClientHooks = ClientHooks + { 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. + -- + -- 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. + -- + -- 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 + -- + -- 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. + -- + -- 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. + -- + -- 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. + -- + -- 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]) + -- ^ 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. + -- + -- 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: + -- + -- (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. + } + +defaultClientHooks :: ClientHooks +defaultClientHooks = + ClientHooks + { onCertificateRequest = \_ -> return Nothing + , onServerCertificate = validateDefault + , onSuggestALPN = return Nothing + , onCustomFFDHEGroup = defaultGroupUsage 1024 + } + +instance Show ClientHooks where + show _ = "ClientHooks" +instance Default ClientHooks where + def = defaultClientHooks + +-- | 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 + -- 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. + -- + -- Default: returns the followings: + -- + -- @ + -- 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. + -- + -- 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. + -- + -- This could be useful with old clients and as a workaround + -- to the BEAST (where RC4 is sometimes prefered 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. + -- + -- 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. + -- + -- Default: returns 'mempty' + , onNewHandshake :: Measurement -> IO Bool + -- ^ 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) + -- ^ 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. + -- + -- Default: 'Nothing' + , onEncryptedExtensionsCreating :: [ExtensionRaw] -> IO [ExtensionRaw] + -- ^ Allow to modify extensions to be sent in EncryptedExtensions + -- of TLS 1.3. + -- + -- Default: 'return' + } + +defaultServerHooks :: ServerHooks +defaultServerHooks = + ServerHooks + { onClientCertificate = \_ -> + return $ + CertificateUsageReject $ + CertificateRejectOther "no client certificates expected" + , onUnverifiedClientCert = return False + , onCipherChoosing = \_ -> head + , onServerNameIndication = \_ -> return mempty + , onNewHandshake = \_ -> return True + , onALPNClientSuggest = Nothing + , onEncryptedExtensionsCreating = return + } instance Show ServerHooks where show _ = "ServerHooks" diff --git a/Network/TLS/PostHandshake.hs b/Network/TLS/PostHandshake.hs --- a/Network/TLS/PostHandshake.hs +++ b/Network/TLS/PostHandshake.hs @@ -1,39 +1,32 @@ --- | --- Module : Network.TLS.PostHandshake --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.PostHandshake - ( requestCertificate - , requestCertificateServer - , postHandshakeAuthWith - , postHandshakeAuthClientWith - , postHandshakeAuthServerWith - ) where +module Network.TLS.PostHandshake ( + requestCertificate, + requestCertificateServer, + postHandshakeAuthWith, + postHandshakeAuthClientWith, + postHandshakeAuthServerWith, +) where import Network.TLS.Context.Internal import Network.TLS.IO import Network.TLS.Struct13 -import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client +import Network.TLS.Handshake.Common import Network.TLS.Handshake.Server -import Control.Monad.State.Strict - -- | Post-handshake certificate request with TLS 1.3. Returns 'True' if the -- request was possible, i.e. if TLS 1.3 is used and the remote client supports -- post-handshake authentication. -requestCertificate :: MonadIO m => Context -> m Bool +requestCertificate :: Context -> IO Bool requestCertificate ctx = - liftIO $ withWriteLock ctx $ - checkValid ctx >> ctxDoRequestCertificate ctx ctx + withWriteLock 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. -postHandshakeAuthWith :: MonadIO m => Context -> Handshake13 -> m () +postHandshakeAuthWith :: Context -> Handshake13 -> IO () postHandshakeAuthWith ctx hs = - liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoPostHandshakeAuthWith ctx ctx hs + withWriteLock ctx $ + handleException ctx $ + doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -1,12 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} + -- | --- Module : Network.TLS.QUIC --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Experimental API to run the TLS handshake establishing a QUIC connection. +-- API to run the TLS handshake establishing a QUIC connection. -- -- On the northbound API: -- @@ -25,47 +20,53 @@ -- exchanged through the handshake protocol. -- -- * TLS calls 'quicDone' when the handshake is done. --- module Network.TLS.QUIC ( -- * Handshakers - tlsQUICClient - , tlsQUICServer + tlsQUICClient, + tlsQUICServer, + -- * Callback - , QUICCallbacks(..) - , CryptLevel(..) - , KeyScheduleEvent(..) + QUICCallbacks (..), + CryptLevel (..), + KeyScheduleEvent (..), + -- * Secrets - , EarlySecretInfo(..) - , HandshakeSecretInfo(..) - , ApplicationSecretInfo(..) - , EarlySecret - , HandshakeSecret - , ApplicationSecret - , TrafficSecrets - , ServerTrafficSecret(..) - , ClientTrafficSecret(..) + EarlySecretInfo (..), + HandshakeSecretInfo (..), + ApplicationSecretInfo (..), + EarlySecret, + HandshakeSecret, + ApplicationSecret, + TrafficSecrets, + ServerTrafficSecret (..), + ClientTrafficSecret (..), + -- * Negotiated parameters - , NegotiatedProtocol - , HandshakeMode13(..) + NegotiatedProtocol, + HandshakeMode13 (..), + -- * Extensions - , ExtensionRaw(..) - , ExtensionID - , extensionID_QuicTransportParameters + ExtensionRaw (..), + ExtensionID (ExtensionID, EID_QuicTransportParameters), + -- * Errors - , errorTLS - , errorToAlertDescription - , errorToAlertMessage - , fromAlertDescription - , toAlertDescription + errorTLS, + errorToAlertDescription, + errorToAlertMessage, + fromAlertDescription, + toAlertDescription, + -- * Hash - , hkdfExpandLabel - , hkdfExtract - , hashDigestSize + hkdfExpandLabel, + hkdfExtract, + hashDigestSize, + -- * Constants - , quicMaxEarlyDataSize + quicMaxEarlyDataSize, + -- * Supported - , defaultSupported - ) where + defaultSupported, +) where import Network.TLS.Backend import Network.TLS.Context @@ -73,14 +74,13 @@ import Network.TLS.Core import Network.TLS.Crypto (hashDigestSize) import Network.TLS.Crypto.Types -import Network.TLS.Extension (extensionID_QuicTransportParameters) import Network.TLS.Extra.Cipher import Network.TLS.Handshake.Common import Network.TLS.Handshake.Control import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Imports -import Network.TLS.KeySchedule (hkdfExtract, hkdfExpandLabel) +import Network.TLS.KeySchedule (hkdfExpandLabel, hkdfExtract) import Network.TLS.Parameters import Network.TLS.Record.Layer import Network.TLS.Record.State @@ -90,87 +90,79 @@ import Data.Default.Class nullBackend :: Backend -nullBackend = Backend { - backendFlush = return () - , backendClose = return () - , backendSend = \_ -> return () - , backendRecv = \_ -> return "" - } +nullBackend = + Backend + { backendFlush = return () + , backendClose = return () + , backendSend = \_ -> return () + , backendRecv = \_ -> return "" + } -- | Argument given to 'quicInstallKeys' when encryption material is available. data KeyScheduleEvent - = InstallEarlyKeys (Maybe EarlySecretInfo) - -- ^ Key material and parameters for traffic at 0-RTT level - | InstallHandshakeKeys HandshakeSecretInfo - -- ^ Key material and parameters for traffic at handshake level - | InstallApplicationKeys ApplicationSecretInfo - -- ^ Key material and parameters for traffic at application level + = -- | Key material and parameters for traffic at 0-RTT level + InstallEarlyKeys (Maybe EarlySecretInfo) + | -- | Key material and parameters for traffic at handshake level + InstallHandshakeKeys HandshakeSecretInfo + | -- | Key material and parameters for traffic at application level + InstallApplicationKeys ApplicationSecretInfo -- | Callbacks implemented by QUIC and to be called by TLS at specific points -- during the handshake. TLS may invoke them from external threads but calls -- are not concurrent. Only a single callback function is called at a given -- point in time. data QUICCallbacks = QUICCallbacks - { 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 - -- given for the specified level and an appropriate encryption scheme. - -- - -- The size of the fragments may exceed QUIC datagram limits so QUIC may - -- break them into smaller fragments. - -- - -- The handshake protocol sometimes combines content at two levels in a - -- single flight. The TLS library does its best to provide this in the - -- same @quicSend@ call and with a multi-valued argument. QUIC can then - -- decide how to transmit this optimally. - , quicRecv :: CryptLevel -> IO (Either TLSError ByteString) - -- ^ Called by TLS to receive from QUIC the next plaintext handshake - -- fragment. The argument specifies with which encryption level the - -- fragment should be decrypted. - -- - -- QUIC may return partial fragments to TLS. TLS will then call - -- @quicRecv@ again as long as necessary. Note however that fragments - -- must be returned in the correct sequence, i.e. the order the TLS peer - -- emitted them. - -- - -- The function may return an error to TLS if end of stream is reached or - -- if a protocol error has been received, believing the handshake cannot - -- proceed any longer. If the TLS handshake protocol cannot recover from - -- this error, the failure condition will be reported back to QUIC through - -- the control interface. - , quicInstallKeys :: Context -> KeyScheduleEvent -> IO () - -- ^ Called by TLS when new encryption material is ready to be used in the - -- handshake. The next 'quicSend' or 'quicRecv' may now use the - -- associated encryption level (although the previous level is also - -- possible: directions Send/Recv do not change at the same time). - , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO () - -- ^ Called by TLS when QUIC-specific extensions have been received from - -- the peer. + { 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 + -- given for the specified level and an appropriate encryption scheme. + -- + -- The size of the fragments may exceed QUIC datagram limits so QUIC may + -- break them into smaller fragments. + -- + -- The handshake protocol sometimes combines content at two levels in a + -- single flight. The TLS library does its best to provide this in the + -- same @quicSend@ call and with a multi-valued argument. QUIC can then + -- decide how to transmit this optimally. + , quicRecv :: CryptLevel -> IO (Either TLSError ByteString) + -- ^ Called by TLS to receive from QUIC the next plaintext handshake + -- fragment. The argument specifies with which encryption level the + -- fragment should be decrypted. + -- + -- QUIC may return partial fragments to TLS. TLS will then call + -- @quicRecv@ again as long as necessary. Note however that fragments + -- must be returned in the correct sequence, i.e. the order the TLS peer + -- emitted them. + -- + -- The function may return an error to TLS if end of stream is reached or + -- if a protocol error has been received, believing the handshake cannot + -- proceed any longer. If the TLS handshake protocol cannot recover from + -- this error, the failure condition will be reported back to QUIC through + -- the control interface. + , quicInstallKeys :: Context -> KeyScheduleEvent -> IO () + -- ^ Called by TLS when new encryption material is ready to be used in the + -- handshake. The next 'quicSend' or 'quicRecv' may now use the + -- associated encryption level (although the previous level is also + -- possible: directions Send/Recv do not change at the same time). + , quicNotifyExtensions :: Context -> [ExtensionRaw] -> IO () + -- ^ Called by TLS when QUIC-specific extensions have been received from + -- the peer. , quicDone :: Context -> IO () - -- ^ Called when 'handshake' is done. 'tlsQUICServer' is - -- finished after calling this hook. 'tlsQUICClient' calls - -- 'recvData' after calling this hook to wait for new session - -- tickets. + -- ^ Called when 'handshake' is done. 'tlsQUICServer' is + -- finished after calling this hook. 'tlsQUICClient' calls + -- 'recvData' after calling this hook to wait for new session + -- tickets. } -getTxLevel :: Context -> IO CryptLevel -getTxLevel ctx = do - (_, _, level, _) <- getTxState ctx - return level - -getRxLevel :: Context -> IO CryptLevel -getRxLevel ctx = do - (_, _, level, _) <- getRxState ctx - return level - -newRecordLayer :: Context -> QUICCallbacks - -> RecordLayer [(CryptLevel, ByteString)] -newRecordLayer ctx callbacks = newTransparentRecordLayer get send recv +newRecordLayer + :: QUICCallbacks + -> RecordLayer [(CryptLevel, ByteString)] +newRecordLayer callbacks = newTransparentRecordLayer get send recv where - get = getTxLevel ctx - send = quicSend callbacks - recv = getRxLevel ctx >>= quicRecv callbacks + get = getTxLevel + send = quicSend callbacks + recv ctx = getRxLevel ctx >>= quicRecv callbacks -- | Start a TLS handshake thread for a QUIC client. The client will use the -- specified TLS parameters and call the provided callback functions to send and @@ -178,12 +170,13 @@ tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams - let ctx1 = ctx0 - { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ()) - , ctxFragmentSize = Nothing - , ctxQUICMode = True - } - rl = newRecordLayer ctx2 callbacks + let ctx1 = + ctx0 + { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ()) + , ctxFragmentSize = Nothing + , ctxQUICMode = True + } + rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2 @@ -196,7 +189,8 @@ sync ctx (SendClientFinished exts appSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do - throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension + throwCore $ + Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -206,12 +200,13 @@ tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams - let ctx1 = ctx0 - { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync - , ctxFragmentSize = Nothing - , ctxQUICMode = True - } - rl = newRecordLayer ctx2 callbacks + let ctx1 = + ctx0 + { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync + , ctxFragmentSize = Nothing + , ctxQUICMode = True + } + rl = newRecordLayer callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 quicDone callbacks ctx2 @@ -219,7 +214,8 @@ sync ctx (SendServerHello exts mEarlySecInfo handSecInfo) = do let qexts = filterQTP exts when (null qexts) $ do - throwCore $ Error_Protocol "QUIC transport parameters are mssing" MissingExtension + throwCore $ + Error_Protocol "QUIC transport parameters are mssing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo) @@ -227,7 +223,9 @@ quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) filterQTP :: [ExtensionRaw] -> [ExtensionRaw] -filterQTP = filter (\(ExtensionRaw eid _) -> eid == extensionID_QuicTransportParameters || eid == 0xffa5) -- to be deleted +filterQTP = + filter + (\(ExtensionRaw eid _) -> eid == EID_QuicTransportParameters) -- | Can be used by callbacks to signal an unexpected condition. This will then -- generate an "internal_error" alert in the TLS stack. @@ -239,23 +237,21 @@ errorToAlertDescription :: TLSError -> AlertDescription errorToAlertDescription = snd . errorToAlert --- | Encode an alert to the assigned value. -fromAlertDescription :: AlertDescription -> Word8 -fromAlertDescription = valOfType - -- | Decode an alert from the assigned value. -toAlertDescription :: Word8 -> Maybe AlertDescription -toAlertDescription = valToType +toAlertDescription :: Word8 -> AlertDescription +toAlertDescription = AlertDescription defaultSupported :: Supported -defaultSupported = def - { supportedVersions = [TLS13] - , supportedCiphers = [ cipher_TLS13_AES256GCM_SHA384 - , cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES128CCM_SHA256 - ] - , supportedGroups = [X25519,X448,P256,P384,P521] - } +defaultSupported = + def + { supportedVersions = [TLS13] + , supportedCiphers = + [ cipher_TLS13_AES256GCM_SHA384 + , cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES128CCM_SHA256 + ] + , supportedGroups = [X25519, X448, P256, P384, P521] + } -- | Max early data size for QUIC. quicMaxEarlyDataSize :: Int diff --git a/Network/TLS/RNG.hs b/Network/TLS/RNG.hs --- a/Network/TLS/RNG.hs +++ b/Network/TLS/RNG.hs @@ -1,17 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Network.TLS.RNG - ( StateRNG(..) - , Seed - , seedNew - , seedToInteger - , seedFromInteger - , withTLSRNG - , newStateRNG - , MonadRandom - , getRandomBytes - ) where -import Crypto.Random.Types +module Network.TLS.RNG ( + StateRNG (..), + Seed, + seedNew, + seedToInteger, + seedFromInteger, + withTLSRNG, + newStateRNG, + MonadRandom, + getRandomBytes, +) where + import Crypto.Random newtype StateRNG = StateRNG ChaChaDRG @@ -20,9 +20,10 @@ instance Show StateRNG where show _ = "rng[..]" -withTLSRNG :: StateRNG - -> MonadPseudoRandom StateRNG a - -> (a, StateRNG) +withTLSRNG + :: StateRNG + -> MonadPseudoRandom StateRNG a + -> (a, StateRNG) withTLSRNG rng f = withDRG rng f newStateRNG :: Seed -> StateRNG diff --git a/Network/TLS/Receiving.hs b/Network/TLS/Receiving.hs --- a/Network/TLS/Receiving.hs +++ b/Network/TLS/Receiving.hs @@ -1,20 +1,13 @@ --- | --- Module : Network.TLS.Receiving --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the Receiving module contains calls related to unmarshalling packets according --- to the TLS state --- {-# LANGUAGE FlexibleContexts #-} -module Network.TLS.Receiving - ( processPacket - , processPacket13 - ) where +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 @@ -29,53 +22,47 @@ import Network.TLS.Util import Network.TLS.Wire -import Control.Concurrent.MVar -import Control.Monad.State.Strict - 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 - + Right _ -> do + switchRxEncryption ctx + return $ Right ChangeCipherSpec processPacket ctx (Record ProtocolType_Handshake ver fragment) = do - keyxchg <- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) + keyxchg <- + getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do - let currentParams = CurrentParams - { cParamsVersion = ver - , cParamsKeyXchgType = keyxchg - } + 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) + 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 _ (Record ProtocolType_DeprecatedHandshake _ fragment) = - case decodeDeprecatedHandshake $ fragmentGetBytes fragment of - Left err -> return $ Left err - Right hs -> return $ Right $ Handshake [hs] + 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 -> - liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) + modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx) ---------------------------------------------------------------- @@ -85,18 +72,19 @@ 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 }) + 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 _ (Record ProtocolType_DeprecatedHandshake _ _) = - return (Left $ Error_Packet "deprecated handshake packet 1.3") + where + parseMany mCont bs = + case fromMaybe decodeHandshakeRecord13 mCont bs of + GotError err -> throwError err + GotPartial cont -> + modify (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return [] + GotSuccess (ty, content) -> + either throwError (return . (: [])) $ decodeHandshake13 ty content + GotSuccessRemaining (ty, content) left -> + case decodeHandshake13 ty content of + Left err -> throwError err + Right hh -> (hh :) <$> parseMany Nothing left +processPacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") diff --git a/Network/TLS/Record.hs b/Network/TLS/Record.hs --- a/Network/TLS/Record.hs +++ b/Network/TLS/Record.hs @@ -1,42 +1,37 @@ --- | --- Module : Network.TLS.Record --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- 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. --- -module Network.TLS.Record - ( Record(..) +-- | 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. +module Network.TLS.Record ( + Record (..), + -- * Fragment manipulation types - , Fragment - , fragmentGetBytes - , fragmentPlaintext - , fragmentCiphertext - , recordToRaw - , rawToRecord - , recordToHeader - , Plaintext - , Compressed - , Ciphertext + Fragment, + fragmentGetBytes, + fragmentPlaintext, + fragmentCiphertext, + recordToRaw, + rawToRecord, + recordToHeader, + Plaintext, + Compressed, + Ciphertext, + -- * Engage and disengage from the record layer - , engageRecord - , disengageRecord + engageRecord, + disengageRecord, + -- * State tracking - , RecordM - , runRecordM - , RecordState(..) - , newRecordState - , getRecordVersion - , setRecordIV - ) where + RecordM, + runRecordM, + RecordState (..), + newRecordState, + getRecordVersion, + setRecordIV, +) where -import Network.TLS.Record.Types -import Network.TLS.Record.Engage import Network.TLS.Record.Disengage +import Network.TLS.Record.Engage import Network.TLS.Record.State +import Network.TLS.Record.Types diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -1,40 +1,25 @@ --- | --- Module : Network.TLS.Record.Disengage --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- Disengage a record from the Record layer. --- The record is decrypted, checked for integrity and then decompressed. --- --- Starting with TLS v1.3, only the "null" compression method is negotiated in --- the handshake, so the decompression step will be a no-op. Decryption and --- integrity verification are performed using an AEAD cipher only. --- {-# LANGUAGE FlexibleContexts #-} -module Network.TLS.Record.Disengage - ( disengageRecord - ) where +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 Crypto.Cipher.Types (AuthTag(..)) -import Network.TLS.Struct +import Network.TLS.Cipher +import Network.TLS.Compression +import Network.TLS.Crypto import Network.TLS.ErrT -import Network.TLS.Cap +import Network.TLS.Imports +import Network.TLS.Packet import Network.TLS.Record.State import Network.TLS.Record.Types -import Network.TLS.Cipher -import Network.TLS.Crypto -import Network.TLS.Compression +import Network.TLS.Struct import Network.TLS.Util import Network.TLS.Wire -import Network.TLS.Packet -import Network.TLS.Imports -import qualified Data.ByteString as B -import qualified Data.ByteArray as B (convert, xor) disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext) disengageRecord = decryptRecord >=> uncompressRecord @@ -48,154 +33,161 @@ st <- get case stCipher st of Nothing -> noDecryption - _ -> do + _ -> 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 + 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 + 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) -> - case valToType c of - Nothing -> Left $ unknownContentType13 c - Just ct - | B.null bytes && ct `elem` nonEmptyContentTypes -> - Left ("empty " ++ show ct ++ " record disallowed") - | otherwise -> Right (ct, bytes) + 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 ] + (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 + 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 `bytesEq` digest) + 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 - cver <- getRecordVersion + Nothing -> return True + Just (pad, _blksz) -> do let b = B.length pad - 1 - return $ if cver < TLS10 - then b < blksz - else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad + return $ B.replicate (B.length pad) (fromIntegral b) == pad unless (macValid &&! paddingValid) $ - throwError $ Error_Protocol "bad record mac" BadRecordMac + throwError $ + Error_Protocol "bad record mac Stream/Block" BadRecordMac return $ cipherDataContent cdata -decryptData :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString +decryptData + :: Version -> Record Ciphertext -> ByteString -> RecordState -> RecordM ByteString decryptData ver record econtent tst = decryptOf (cstKey cst) - where cipher = fromJust "cipher" $ stCipher tst - bulk = cipherBulk cipher - cst = stCryptState tst - macSize = hashDigestSize $ cipherHash cipher - blockSize = bulkBlockSize bulk - econtentLen = B.length econtent - - explicitIV = hasExplicitBlockIV ver - - sanityCheckError = throwError (Error_Packet "encrypted content too small for encryption parameters") - - decryptOf :: BulkState -> RecordM ByteString - decryptOf (BulkStateBlock decryptF) = do - let minContent = (if explicitIV then bulkIVSize bulk else 0) + 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 + where + cipher = fromJust $ stCipher tst + bulk = cipherBulk cipher + cst = stCryptState tst + macSize = hashDigestSize $ cipherHash cipher + blockSize = bulkBlockSize bulk + econtentLen = B.length econtent - {- update IV -} - (iv, econtent') <- if explicitIV - then get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk) - else return (cstIV cst, econtent) - let (content', iv') = decryptF iv econtent' - modify $ \txs -> txs { stCryptState = cst { cstIV = iv' } } + sanityCheckError = + throwError + (Error_Packet "encrypted content too small for encryption parameters") - 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 :: BulkState -> RecordM ByteString + decryptOf (BulkStateBlock decryptF) = do + let minContent = bulkIVSize bulk + max (macSize + 1) blockSize - decryptOf (BulkStateStream (BulkStream decryptF)) = do - -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < macSize) sanityCheckError + -- check if we have enough bytes to cover the minimum for this cipher + when + ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) + 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 - } + {- update IV -} + (iv, econtent') <- + get2o econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk) + let (content', iv') = decryptF iv econtent' + modify $ \txs -> txs{stCryptState = cst{cstIV = iv'}} - decryptOf (BulkStateAEAD decryptF) = do - let authTagLen = bulkAuthTagLen bulk - nonceExpLen = bulkExplicitIV bulk - cipherLen = econtentLen - authTagLen - nonceExpLen + 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 - -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < (authTagLen + nonceExpLen)) 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 - (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 + -- check if we have enough bytes to cover the minimum for this cipher + when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError - when (AuthTag (B.convert authTag) /= authTag2) $ - throwError $ Error_Protocol "bad record mac" BadRecordMac + (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 - modify incrRecordState - return content + when (AuthTag (B.convert authTag) /= authTag2) $ + throwError $ + Error_Protocol "bad record mac on AEAD" BadRecordMac - decryptOf BulkStateUninitialized = - throwError $ Error_Protocol "decrypt state uninitialized" InternalError + 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) + -- 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) + -- all format errors related to decrypted content are reported + -- externally as integrity failures, i.e. BadRecordMac + get3i s ls = + maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ + partition3 s ls + get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs --- a/Network/TLS/Record/Engage.hs +++ b/Network/TLS/Record/Engage.hs @@ -1,36 +1,28 @@ +{-# LANGUAGE BangPatterns #-} + -- | --- Module : Network.TLS.Record.Engage --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -- Engage a record into the Record layer. -- The record is compressed, added some integrity field, then encrypted. -- -- Starting with TLS v1.3, only the "null" compression method is negotiated in -- the handshake, so the compression step will be a no-op. Integrity and -- encryption are performed using an AEAD cipher only. --- -{-# LANGUAGE BangPatterns #-} -module Network.TLS.Record.Engage - ( engageRecord - ) where +module Network.TLS.Record.Engage ( + engageRecord, +) where import Control.Monad.State.Strict -import Crypto.Cipher.Types (AuthTag(..)) +import Crypto.Cipher.Types (AuthTag (..)) -import Network.TLS.Cap -import Network.TLS.Record.State -import Network.TLS.Record.Types +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.Wire -import Network.TLS.Packet -import Network.TLS.Struct import Network.TLS.Imports -import qualified Data.ByteString as B -import qualified Data.ByteArray as B (convert, xor) +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 @@ -58,29 +50,29 @@ encryptContent13 | ct == ProtocolType_ChangeCipherSpec = noEncryption | otherwise = do - let bytes = fragmentGetBytes fragment + let bytes = fragmentGetBytes fragment fragment' = fragmentCompressed $ innerPlaintext ct bytes - record' = Record ProtocolType_AppData ver fragment' + record' = Record ProtocolType_AppData ver fragment' onRecordFragment record' $ fragmentCipher (encryptContent True record') innerPlaintext :: ProtocolType -> ByteString -> ByteString -innerPlaintext ct bytes = runPut $ do +innerPlaintext (ProtocolType c) bytes = runPut $ do putBytes bytes - putWord8 $ valOfType ct -- non zero! + putWord8 c -- non zero! -- fixme: zeros padding encryptContent :: Bool -> Record Compressed -> ByteString -> RecordM ByteString encryptContent tls13 record content = do - cst <- getCryptState + cst <- getCryptState bulk <- getBulk case cstKey cst of BulkStateBlock encryptF -> do digest <- makeDigest (recordToHeader record) content - let content' = B.concat [content, digest] + let content' = B.concat [content, digest] encryptBlock encryptF content' bulk BulkStateStream encryptF -> do digest <- makeDigest (recordToHeader record) content - let content' = B.concat [content, digest] + let content' = B.concat [content, digest] encryptStream encryptF content' BulkStateAEAD encryptF -> encryptAead tls13 bulk encryptF content record @@ -90,55 +82,56 @@ encryptBlock :: BulkBlock -> ByteString -> Bulk -> RecordM ByteString encryptBlock encryptF content bulk = do cst <- getCryptState - ver <- getRecordVersion 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 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 ] + let (e, _iv') = encryptF (cstIV cst) $ B.concat [content, padding] - if hasExplicitBlockIV ver - then return $ B.concat [cstIV cst,e] - else do - modify $ \tstate -> tstate { stCryptState = cst { cstIV = iv' } } - return e + 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 } } + modify $ \tstate -> tstate{stCryptState = cst{cstKey = BulkStateStream newBulkStream}} return e -encryptAead :: Bool - -> Bulk - -> BulkAEAD - -> ByteString -> Record Compressed - -> RecordM ByteString +encryptAead + :: Bool + -> Bulk + -> BulkAEAD + -> ByteString + -> Record Compressed + -> RecordM ByteString encryptAead tls13 bulk encryptF content record = do - let authTagLen = bulkAuthTagLen bulk + let authTagLen = bulkAuthTagLen bulk nonceExpLen = bulkExplicitIV bulk - cst <- getCryptState + cst <- getCryptState encodedSeq <- encodeWord64 <$> getMacSequence - let iv = cstIV cst + let iv = cstIV cst ivlen = B.length iv Header typ v plainLen = recordToHeader record hdrLen = if tls13 then plainLen + fromIntegral authTagLen else plainLen hdr = Header typ v hdrLen - ad | tls13 = encodeHeader hdr - | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] - sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq - nonce | nonceExpLen == 0 = B.xor iv sqnc - | otherwise = B.concat [iv, encodedSeq] + 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] + econtent + | nonceExpLen == 0 = e `B.append` B.convert authtag + | otherwise = B.concat [encodedSeq, e, B.convert authtag] modify incrRecordState return econtent diff --git a/Network/TLS/Record/Layer.hs b/Network/TLS/Record/Layer.hs --- a/Network/TLS/Record/Layer.hs +++ b/Network/TLS/Record/Layer.hs @@ -1,63 +1,64 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.TLS.Record.Layer ( - RecordLayer(..) - , newTransparentRecordLayer - ) where + RecordLayer (..), + newTransparentRecordLayer, +) where +import Network.TLS.Context import Network.TLS.Imports import Network.TLS.Record import Network.TLS.Struct import qualified Data.ByteString as B -data RecordLayer bytes = RecordLayer { - -- Writing.hs - recordEncode :: Record Plaintext -> IO (Either TLSError bytes) - , recordEncode13 :: Record Plaintext -> IO (Either TLSError bytes) - , recordSendBytes :: bytes -> IO () - - -- Reading.hs - , recordRecv :: Bool -> Int -> IO (Either TLSError (Record Plaintext)) - , recordRecv13 :: IO (Either TLSError (Record Plaintext)) - } - -newTransparentRecordLayer :: Eq ann - => IO ann -> ([(ann, ByteString)] -> IO ()) - -> IO (Either TLSError ByteString) - -> RecordLayer [(ann, ByteString)] -newTransparentRecordLayer get send recv = RecordLayer { - recordEncode = transparentEncodeRecord get - , recordEncode13 = transparentEncodeRecord get - , recordSendBytes = transparentSendBytes send - , recordRecv = \_ _ -> transparentRecvRecord recv - , recordRecv13 = transparentRecvRecord recv - } +newTransparentRecordLayer + :: Eq ann + => (Context -> IO ann) + -> ([(ann, ByteString)] -> IO ()) + -> (Context -> IO (Either TLSError ByteString)) + -> RecordLayer [(ann, ByteString)] +newTransparentRecordLayer get send recv = + RecordLayer + { recordEncode = transparentEncodeRecord get + , recordEncode13 = transparentEncodeRecord get + , recordSendBytes = transparentSendBytes send + , recordRecv = \ctx _ -> transparentRecvRecord recv ctx + , recordRecv13 = transparentRecvRecord recv + } -transparentEncodeRecord :: IO ann -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)]) -transparentEncodeRecord _ (Record ProtocolType_ChangeCipherSpec _ _) = +transparentEncodeRecord + :: (Context -> IO ann) + -> Context + -> Record Plaintext + -> IO (Either TLSError [(ann, ByteString)]) +transparentEncodeRecord _ _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right [] -transparentEncodeRecord _ (Record ProtocolType_Alert _ _) = +transparentEncodeRecord _ _ (Record ProtocolType_Alert _ _) = -- all alerts are silent and must be transported externally based on -- TLS exceptions raised by the library return $ Right [] -transparentEncodeRecord get (Record _ _ frag) = - get >>= \a -> return $ Right [(a, fragmentGetBytes frag)] +transparentEncodeRecord get ctx (Record _ _ frag) = + get ctx >>= \a -> return $ Right [(a, fragmentGetBytes frag)] -transparentSendBytes :: Eq ann => ([(ann, ByteString)] -> IO ()) -> [(ann, ByteString)] -> IO () -transparentSendBytes send input = send - [ (a, bs) | (a, frgs) <- compress input - , let bs = B.concat frgs - , not (B.null bs) - ] +transparentSendBytes + :: Eq ann + => ([(ann, ByteString)] -> IO ()) + -> Context + -> [(ann, ByteString)] + -> IO () +transparentSendBytes send _ input = + send + [ (a, bs) | (a, frgs) <- compress input, let bs = B.concat frgs, not (B.null bs) + ] -transparentRecvRecord :: IO (Either TLSError ByteString) - -> IO (Either TLSError (Record Plaintext)) -transparentRecvRecord recv = - fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv +transparentRecvRecord + :: (Context -> IO (Either TLSError ByteString)) + -> Context + -> IO (Either TLSError (Record Plaintext)) +transparentRecvRecord recv ctx = + fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv ctx compress :: Eq ann => [(ann, val)] -> [(ann, [val])] -compress [] = [] -compress ((a,v):xs) = +compress [] = [] +compress ((a, v) : xs) = let (ys, zs) = span ((== a) . fst) xs in (a, v : map snd ys) : compress zs diff --git a/Network/TLS/Record/Reading.hs b/Network/TLS/Record/Reading.hs --- a/Network/TLS/Record/Reading.hs +++ b/Network/TLS/Record/Reading.hs @@ -1,19 +1,9 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Network.TLS.Record.Reading --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- TLS record layer in Rx direction --- -module Network.TLS.Record.Reading - ( recvRecord - , recvRecord13 - ) where +-- | TLS record layer in Rx direction +module Network.TLS.Record.Reading ( + recvRecord, + recvRecord13, +) where -import Control.Monad.Reader import qualified Data.ByteString as B import Network.TLS.Context.Internal @@ -32,21 +22,27 @@ Nothing -> False Just sz -> fromIntegral actual > sz + overhead -getRecord :: Context -> Int -> Header -> ByteString -> IO (Either TLSError (Record Plaintext)) +getRecord + :: Context + -> Int + -> Header + -> ByteString + -> IO (Either TLSError (Record Plaintext)) getRecord ctx appDataOverhead header@(Header pt _ _) content = do withLog ctx $ \logging -> loggingIORecv logging header content - runRxState ctx $ do + 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 + 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) + where + erecord = rawToRecord header (fragmentCiphertext content) contentSizeExceeded :: TLSError contentSizeExceeded = Error_Protocol "record content exceeding maximum size" RecordOverflow @@ -56,49 +52,32 @@ -- | recvRecord receive a full TLS record (header + data), from the other side. -- -- The record is disengaged from the record layer -recvRecord :: Context -- ^ TLS context - -> Bool -- ^ flag to enable SSLv2 compat ClientHello reception - -> Int -- ^ number of AppData bytes to accept above normal maximum size - -> IO (Either TLSError (Record Plaintext)) -recvRecord ctx compatSSLv2 appDataOverhead -#ifdef SSLV2_COMPATIBLE - | compatSSLv2 = readExactBytes ctx 2 >>= either (return . Left) sslv2Header -#endif - | otherwise = 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) -#ifdef SSLV2_COMPATIBLE - sslv2Header header = - if B.head header >= 0x80 - then either (return . Left) recvDeprecatedLength $ decodeDeprecatedHeaderLength header - else readExactBytes ctx 3 >>= - either (return . Left) (recvLengthE . decodeHeader . B.append header) +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 - recvDeprecatedLength readlen - | readlen > 1024 * 4 = return $ Left maximumSizeExceeded - | otherwise = do - res <- readExactBytes ctx (fromIntegral readlen) - case res of - Left e -> return $ Left e - Right content -> - let hdr = decodeDeprecatedHeader readlen (B.take 3 content) - in either (return . Left) (\h -> getRecord ctx appDataOverhead h content) hdr -#endif + 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) + 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 @@ -115,4 +94,10 @@ return . Left $ if B.null hdrbs then Error_EOF - else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) + else + Error_Packet + ( "partial packet: expecting " + ++ show sz + ++ " bytes, got: " + ++ show (B.length hdrbs) + ) diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -1,106 +1,110 @@ {-# LANGUAGE MultiParamTypeClasses #-} --- | --- Module : Network.TLS.Record.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Record.State - ( CryptState(..) - , CryptLevel(..) - , HasCryptLevel(..) - , MacState(..) - , RecordOptions(..) - , RecordState(..) - , newRecordState - , incrRecordState - , RecordM - , runRecordM - , getRecordOptions - , getRecordVersion - , setRecordIV - , withCompression - , computeDigest - , makeDigest - , getBulk - , getMacSequence - ) where +module Network.TLS.Record.State ( + CryptState (..), + CryptLevel (..), + HasCryptLevel (..), + MacState (..), + RecordOptions (..), + RecordState (..), + newRecordState, + incrRecordState, + RecordM, + runRecordM, + getRecordOptions, + getRecordVersion, + setRecordIV, + withCompression, + computeDigest, + makeDigest, + getBulk, + getMacSequence, +) where + import Control.Monad.State.Strict -import Network.TLS.Compression +import qualified Data.ByteString as B + import Network.TLS.Cipher +import Network.TLS.Compression import Network.TLS.ErrT -import Network.TLS.Struct -import Network.TLS.Wire - -import Network.TLS.Packet -import Network.TLS.MAC -import Network.TLS.Util import Network.TLS.Imports +import Network.TLS.MAC +import Network.TLS.Packet +import Network.TLS.Struct import Network.TLS.Types - -import qualified Data.ByteString as B +import Network.TLS.Wire data CryptState = CryptState - { cstKey :: !BulkState - , cstIV :: !ByteString - -- In TLS 1.2 or earlier, this holds mac secret. - -- In TLS 1.3, this holds application traffic secret N. - , cstMacSecret :: !ByteString - } deriving (Show) + { cstKey :: BulkState + , cstIV :: ByteString + , -- In TLS 1.2 or earlier, this holds mac secret. + -- In TLS 1.3, this holds application traffic secret N. + cstMacSecret :: ByteString + } + deriving (Show) newtype MacState = MacState { msSequence :: Word64 - } deriving (Show) + } + deriving (Show) data RecordOptions = RecordOptions - { recordVersion :: Version -- version to use when sending/receiving - , recordTLS13 :: Bool -- TLS13 record processing + { recordVersion :: Version -- version to use when sending/receiving + , recordTLS13 :: Bool -- TLS13 record processing } -- | TLS encryption level. data CryptLevel - = CryptInitial -- ^ Unprotected traffic - | CryptMasterSecret -- ^ Protected with master secret (TLS < 1.3) - | CryptEarlySecret -- ^ Protected with early traffic secret (TLS 1.3) - | CryptHandshakeSecret -- ^ Protected with handshake traffic secret (TLS 1.3) - | CryptApplicationSecret -- ^ Protected with application traffic secret (TLS 1.3) - deriving (Eq,Show) + = -- | Unprotected traffic + CryptInitial + | -- | Protected with main secret (TLS < 1.3) + CryptMainSecret + | -- | Protected with early traffic secret (TLS 1.3) + CryptEarlySecret + | -- | Protected with handshake traffic secret (TLS 1.3) + CryptHandshakeSecret + | -- | Protected with application traffic secret (TLS 1.3) + CryptApplicationSecret + deriving (Eq, Show) class HasCryptLevel a where getCryptLevel :: proxy a -> CryptLevel instance HasCryptLevel EarlySecret where getCryptLevel _ = CryptEarlySecret -instance HasCryptLevel HandshakeSecret where getCryptLevel _ = CryptHandshakeSecret -instance HasCryptLevel ApplicationSecret where getCryptLevel _ = CryptApplicationSecret +instance HasCryptLevel HandshakeSecret where + getCryptLevel _ = CryptHandshakeSecret +instance HasCryptLevel ApplicationSecret where + getCryptLevel _ = CryptApplicationSecret data RecordState = RecordState - { stCipher :: Maybe Cipher + { stCipher :: Maybe Cipher , stCompression :: Compression - , stCryptLevel :: !CryptLevel - , stCryptState :: !CryptState - , stMacState :: !MacState - } deriving (Show) + , stCryptLevel :: CryptLevel + , stCryptState :: CryptState + , stMacState :: MacState + } + deriving (Show) -newtype RecordM a = RecordM { runRecordM :: RecordOptions - -> RecordState - -> Either TLSError (a, RecordState) } +newtype RecordM a = RecordM + { runRecordM + :: RecordOptions + -> RecordState + -> Either TLSError (a, RecordState) + } instance Applicative RecordM where - pure = return + pure a = RecordM $ \_ st -> Right (a, st) (<*>) = ap instance Monad RecordM where - return a = RecordM $ \_ st -> Right (a, st) m1 >>= m2 = RecordM $ \opt st -> - case runRecordM m1 opt st of - Left err -> Left err - Right (a, st2) -> runRecordM (m2 a) opt st2 + case runRecordM m1 opt st of + Left err -> Left err + Right (a, st2) -> runRecordM (m2 a) opt st2 instance Functor RecordM where fmap f m = RecordM $ \opt st -> - case runRecordM m opt st of - Left err -> Left err - Right (a, st2) -> Right (f a, st2) + case runRecordM m opt st of + Left err -> Left err + Right (a, st2) -> Right (f a, st2) getRecordOptions :: RecordM RecordOptions getRecordOptions = RecordM $ \opt st -> Right (opt, st) @@ -109,51 +113,53 @@ getRecordVersion = recordVersion <$> getRecordOptions instance MonadState RecordState RecordM where - put x = RecordM $ \_ _ -> Right ((), x) - get = RecordM $ \_ st -> Right (st, st) + put x = RecordM $ \_ _ -> Right ((), x) + get = RecordM $ \_ st -> Right (st, st) state f = RecordM $ \_ st -> Right (f st) instance MonadError TLSError RecordM where - throwError e = RecordM $ \_ _ -> Left e + throwError e = RecordM $ \_ _ -> Left e catchError m f = RecordM $ \opt st -> - case runRecordM m opt st of - Left err -> runRecordM (f err) opt st - r -> r + case runRecordM m opt st of + Left err -> runRecordM (f err) opt st + r -> r newRecordState :: RecordState -newRecordState = RecordState - { stCipher = Nothing - , stCompression = nullCompression - , stCryptLevel = CryptInitial - , stCryptState = CryptState BulkStateUninitialized B.empty B.empty - , stMacState = MacState 0 - } +newRecordState = + RecordState + { stCipher = Nothing + , stCompression = nullCompression + , stCryptLevel = CryptInitial + , stCryptState = CryptState BulkStateUninitialized B.empty B.empty + , stMacState = MacState 0 + } incrRecordState :: RecordState -> RecordState -incrRecordState ts = ts { stMacState = MacState (ms + 1) } - where (MacState ms) = stMacState ts +incrRecordState ts = ts{stMacState = MacState (ms + 1)} + where + (MacState ms) = stMacState ts setRecordIV :: ByteString -> RecordState -> RecordState -setRecordIV iv st = st { stCryptState = (stCryptState st) { cstIV = iv } } +setRecordIV iv st = st{stCryptState = (stCryptState st){cstIV = iv}} withCompression :: (Compression -> (Compression, a)) -> RecordM a withCompression f = do st <- get let (nc, a) = f $ stCompression st - put $ st { stCompression = nc } + put $ st{stCompression = nc} return a -computeDigest :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) -computeDigest ver tstate hdr content = (digest, incrRecordState tstate) - where digest = macF (cstMacSecret cst) msg - cst = stCryptState tstate - cipher = fromJust "cipher" $ stCipher tstate - hashA = cipherHash cipher - encodedSeq = encodeWord64 $ msSequence $ stMacState tstate +computeDigest + :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) +computeDigest _ver tstate hdr content = (digest, incrRecordState tstate) + where + digest = macF (cstMacSecret cst) msg + cst = stCryptState tstate + cipher = fromJust $ stCipher tstate + hashA = cipherHash cipher + encodedSeq = encodeWord64 $ msSequence $ stMacState tstate - (macF, msg) - | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) - | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ]) + (macF, msg) = (hmac hashA, B.concat [encodedSeq, encodeHeader hdr, content]) makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do @@ -164,7 +170,7 @@ return digest getBulk :: RecordM Bulk -getBulk = cipherBulk . fromJust "cipher" . stCipher <$> get +getBulk = cipherBulk . fromJust . stCipher <$> get getMacSequence :: RecordM Word64 getMacSequence = msSequence . stMacState <$> get diff --git a/Network/TLS/Record/Types.hs b/Network/TLS/Record/Types.hs --- a/Network/TLS/Record/Types.hs +++ b/Network/TLS/Record/Types.hs @@ -1,53 +1,51 @@ {-# LANGUAGE EmptyDataDecls #-} --- | --- Module : Network.TLS.Record.Types --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- 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. --- -module Network.TLS.Record.Types - ( Header(..) - , ProtocolType(..) - , packetType + +-- | 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. +module Network.TLS.Record.Types ( + Header (..), + ProtocolType (..), + packetType, + -- * TLS Records - , Record(..) + Record (..), + -- * TLS Record fragment and constructors - , Fragment - , fragmentGetBytes - , fragmentPlaintext - , fragmentCompressed - , fragmentCiphertext - , Plaintext - , Compressed - , Ciphertext + Fragment, + fragmentGetBytes, + fragmentPlaintext, + fragmentCompressed, + fragmentCiphertext, + Plaintext, + Compressed, + Ciphertext, + -- * manipulate record - , onRecordFragment - , fragmentCompress - , fragmentCipher - , fragmentUncipher - , fragmentUncompress + onRecordFragment, + fragmentCompress, + fragmentCipher, + fragmentUncipher, + fragmentUncompress, + -- * serialize record - , rawToRecord - , recordToRaw - , recordToHeader - ) where + rawToRecord, + recordToRaw, + recordToHeader, +) where -import Network.TLS.Struct +import qualified Data.ByteString as B import Network.TLS.Imports import Network.TLS.Record.State -import qualified Data.ByteString as B +import Network.TLS.Struct -- | Represent a TLS record. -data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq) +data Record a = Record ProtocolType Version (Fragment a) deriving (Show, Eq) -newtype Fragment a = Fragment { fragmentGetBytes :: ByteString } deriving (Show,Eq) +newtype Fragment a = Fragment {fragmentGetBytes :: ByteString} + deriving (Show, Eq) data Plaintext data Compressed @@ -62,26 +60,40 @@ fragmentCiphertext :: ByteString -> Fragment Ciphertext fragmentCiphertext bytes = Fragment bytes -onRecordFragment :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) +onRecordFragment + :: Record a -> (Fragment a -> RecordM (Fragment b)) -> RecordM (Record b) onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag -fragmentMap :: (ByteString -> RecordM ByteString) -> Fragment a -> RecordM (Fragment b) +fragmentMap + :: (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 + :: (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 -> RecordM (Fragment Ciphertext) +fragmentCipher + :: (ByteString -> RecordM ByteString) + -> Fragment Compressed + -> RecordM (Fragment Ciphertext) fragmentCipher f = fragmentMap f -- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied -fragmentUncipher :: (ByteString -> RecordM ByteString) -> Fragment Ciphertext -> RecordM (Fragment Compressed) +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 + :: (ByteString -> RecordM ByteString) + -> Fragment Compressed + -> RecordM (Fragment Plaintext) fragmentUncompress f = fragmentMap f -- | turn a record into an header and bytes diff --git a/Network/TLS/Record/Writing.hs b/Network/TLS/Record/Writing.hs --- a/Network/TLS/Record/Writing.hs +++ b/Network/TLS/Record/Writing.hs @@ -1,27 +1,16 @@ --- | --- Module : Network.TLS.Record.Writing --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- TLS record layer in Tx direction --- -module Network.TLS.Record.Writing - ( encodeRecord - , encodeRecord13 - , sendBytes - ) where +-- | TLS record layer in Tx direction +module Network.TLS.Record.Writing ( + encodeRecord, + encodeRecord13, + sendBytes, +) where -import Network.TLS.Cap import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.Packet -import Network.TLS.Parameters import Network.TLS.Record -import Network.TLS.State import Network.TLS.Struct import Control.Concurrent.MVar @@ -35,23 +24,24 @@ -- 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 - ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) - txState <- readMVar $ ctxTxState ctx + 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 hasExplicitBlockIV ver && sz > 0 - then do newIV <- getStateRNG ctx sz - runTxState ctx (modify (setRecordIV newIV) >> f) - else runTxState ctx f + 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 ] + return $ B.concat [encodeHeader hdr, content] ---------------------------------------------------------------- @@ -59,7 +49,7 @@ encodeRecord13 ctx = prepareRecord13 ctx . encodeRecordM prepareRecord13 :: Context -> RecordM a -> IO (Either TLSError a) -prepareRecord13 = runTxState +prepareRecord13 = runTxRecordState ---------------------------------------------------------------- diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -1,20 +1,15 @@ --- | --- Module : Network.TLS.Sending --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the Sending module contains calls related to marshalling packets according --- to the TLS state --- module Network.TLS.Sending ( - encodePacket - , encodePacket13 - , updateHandshake - , updateHandshake13 - ) where + 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 @@ -25,87 +20,95 @@ import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.Record -import Network.TLS.Record.Layer import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13 -import Network.TLS.Types (Role(..)) +import Network.TLS.Types (Role (..)) import Network.TLS.Util -import Control.Concurrent.MVar -import Control.Monad.State.Strict -import qualified Data.ByteString as B -import Data.IORef - -- | encodePacket transform a packet into marshalled data related to current state -- and updating state on the go -encodePacket :: Monoid bytes - => Context -> RecordLayer bytes -> Packet -> IO (Either TLSError bytes) -encodePacket ctx recordLayer pkt = do +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 <$> packetToFragments ctx len pkt - bs <- fmap mconcat <$> forEitherM records (recordEncode recordLayer) + 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. -packetToFragments :: Context -> Maybe Int -> Packet -> IO [ByteString] -packetToFragments ctx len (Handshake hss) = - getChunks len . B.concat <$> mapM (updateHandshake ctx ClientRole) hss -packetToFragments _ _ (Alert a) = return [encodeAlerts a] -packetToFragments _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] -packetToFragments _ _ (AppData x) = return [x] +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 "tx-state" <$> gets hstPendingTxState) - (ver, cc) <- usingState_ ctx $ do v <- getVersion - c <- isClientContext - return (v, c) - liftIO $ modifyMVar_ (ctxTxState ctx) (\_ -> return tx) + 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 && cc == ClientRole && isCBC tx && supportedEmptyPacket (ctxSupported ctx)) $ liftIO $ writeIORef (ctxNeedEmptyPacket ctx) True - where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) + 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) -updateHandshake :: Context -> Role -> Handshake -> IO ByteString -updateHandshake ctx role hs = do - case hs of - Finished fdata -> usingState_ ctx $ updateVerifiedData role fdata - _ -> return () +updateHandshake12 :: Context -> Handshake -> IO ByteString +updateHandshake12 ctx hs = do usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded + when (finishedHandshakeMaterial hs) $ updateHandshakeDigest encoded return encoded where encoded = encodeHandshake hs ---------------------------------------------------------------- -encodePacket13 :: Monoid bytes - => Context -> RecordLayer bytes -> Packet13 -> IO (Either TLSError bytes) +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) + fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx) packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString] -packetToFragments13 ctx len (Handshake13 hss) = +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] +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 + | otherwise = usingHState ctx $ do when (isHRR hs) wrapAsMessageHash13 updateHandshakeDigest encoded addHandshakeMessage encoded @@ -114,8 +117,8 @@ encoded = encodeHandshake13 hs isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand - isHRR _ = False + isHRR _ = False isIgnored NewSessionTicket13{} = True - isIgnored KeyUpdate13{} = True - isIgnored _ = False + isIgnored KeyUpdate13{} = True + isIgnored _ = False diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -1,34 +1,33 @@ --- | --- Module : Network.TLS.Session --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Session - ( SessionManager(..) - , noSessionManager - ) where +module Network.TLS.Session ( + SessionManager (..), + noSessionManager, +) where import Network.TLS.Types -- | A session manager data SessionManager = SessionManager - { -- | used on server side to decide whether to resume a client session. - sessionResume :: SessionID -> IO (Maybe SessionData) - -- | used on server side to decide whether to resume a client session for TLS 1.3 0RTT. For a given 'SessionID', the implementation must return its 'SessionData' only once and must not return the same 'SessionData' after the call. - , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData) - -- | used when a session is established. - , sessionEstablish :: SessionID -> SessionData -> IO () - -- | used when a session is invalidated. - , sessionInvalidate :: SessionID -> IO () + { 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'. + , 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. } -- | The session manager to do nothing. noSessionManager :: SessionManager -noSessionManager = SessionManager - { sessionResume = \_ -> return Nothing - , sessionResumeOnlyOnce = \_ -> return Nothing - , sessionEstablish = \_ _ -> return () - , sessionInvalidate = \_ -> return () - } +noSessionManager = + SessionManager + { sessionResume = \_ -> return Nothing + , sessionResumeOnlyOnce = \_ -> return Nothing + , sessionEstablish = \_ _ -> return Nothing + , sessionInvalidate = \_ -> return () + , -- Don't send NewSessionTicket in TLS 1.2 by default. + -- Send NewSessionTicket with SessionID in TLS 1.3 by default. + sessionUseTicket = False + } diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -1,183 +1,204 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | --- Module : Network.TLS.State --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the State module contains calls related to state initialization/manipulation --- which is use by the Receiving module and the Sending module. --- -module Network.TLS.State - ( TLSState(..) - , TLSSt - , runTLSState - , newTLSState - , withTLSRNG - , updateVerifiedData - , finishHandshakeTypeMaterial - , finishHandshakeMaterial - , certVerifyHandshakeTypeMaterial - , certVerifyHandshakeMaterial - , setVersion - , setVersionIfUnset - , getVersion - , getVersionWithDefault - , setSecureRenegotiation - , getSecureRenegotiation - , setExtensionALPN - , getExtensionALPN - , setNegotiatedProtocol - , getNegotiatedProtocol - , setClientALPNSuggest - , getClientALPNSuggest - , setClientEcPointFormatSuggest - , getClientEcPointFormatSuggest - , getClientCertificateChain - , setClientCertificateChain - , setClientSNI - , getClientSNI - , getVerifiedData - , setSession - , getSession - , isSessionResuming - , isClientContext - , setExporterMasterSecret - , getExporterMasterSecret - , setTLS13KeyShare - , getTLS13KeyShare - , setTLS13PreSharedKey - , getTLS13PreSharedKey - , setTLS13HRR - , getTLS13HRR - , setTLS13Cookie - , getTLS13Cookie - , setClientSupportsPHA - , getClientSupportsPHA +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +-- | the State module contains calls related to state +-- initialization/manipulation which is use by the Receiving module +-- and the Sending module. +module Network.TLS.State ( + TLSState (..), + TLSSt, + runTLSState, + newTLSState, + withTLSRNG, + setVerifyDataForSend, + setVerifyDataForRecv, + getVerifyData, + getMyVerifyData, + getPeerVerifyData, + getFirstVerifyData, + finishedHandshakeTypeMaterial, + finishedHandshakeMaterial, + certVerifyHandshakeTypeMaterial, + certVerifyHandshakeMaterial, + setVersion, + setVersionIfUnset, + getVersion, + getVersionWithDefault, + setSecureRenegotiation, + getSecureRenegotiation, + setExtensionALPN, + getExtensionALPN, + setNegotiatedProtocol, + getNegotiatedProtocol, + setClientALPNSuggest, + getClientALPNSuggest, + setClientEcPointFormatSuggest, + getClientEcPointFormatSuggest, + setClientSNI, + getClientSNI, + getClientCertificateChain, + setClientCertificateChain, + getServerCertificateChain, + setServerCertificateChain, + setSession, + getSession, + isSessionResuming, + getRole, + setExporterSecret, + getExporterSecret, + setTLS13KeyShare, + getTLS13KeyShare, + setTLS13PreSharedKey, + getTLS13PreSharedKey, + setTLS13HRR, + getTLS13HRR, + setTLS13Cookie, + getTLS13Cookie, + setClientSupportsPHA, + getClientSupportsPHA, + setTLS12SessionTicket, + getTLS12SessionTicket, + -- * random - , genRandom - , withRNG - ) where + genRandom, + withRNG, +) where -import Network.TLS.Imports -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.RNG -import Network.TLS.Types (Role(..), HostName) -import Network.TLS.Wire (GetContinuation) -import Network.TLS.Extension -import qualified Data.ByteString as B import Control.Monad.State.Strict -import Network.TLS.ErrT 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.Wire (GetContinuation) data TLSState = TLSState - { stSession :: Session - , stSessionResuming :: Bool - , stSecureRenegotiation :: Bool -- RFC 5746 - , stClientVerifiedData :: ByteString -- RFC 5746 - , stServerVerifiedData :: ByteString -- RFC 5746 - , stExtensionALPN :: Bool -- RFC 7301 + { stSession :: Session + , stSessionResuming :: Bool + , -- RFC 5746, Renegotiation Indication Extension + -- RFC 5929, Channel Bindings for TLS, "tls-unique" + stSecureRenegotiation :: Bool + , stClientVerifyData :: Maybe VerifyData + , stServerVerifyData :: Maybe VerifyData + , -- 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 (HandshakeType13, ByteString)) - , stClientALPNSuggest :: Maybe [B.ByteString] - , stClientGroupSuggest :: Maybe [Group] + , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol + , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString)) + , stClientALPNSuggest :: Maybe [B.ByteString] + , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain - , stClientSNI :: Maybe HostName - , stRandomGen :: StateRNG - , stVersion :: Maybe Version - , stClientContext :: Role - , stTLS13KeyShare :: Maybe KeyShare - , stTLS13PreSharedKey :: Maybe PreSharedKey - , stTLS13HRR :: !Bool - , stTLS13Cookie :: Maybe Cookie - , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3 - , stClientSupportsPHA :: !Bool -- Post-Handshake Authentication (TLS 1.3) + , stClientSNI :: Maybe HostName + , stRandomGen :: StateRNG + , stVersion :: Maybe Version + , stClientContext :: Role + , 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 } -newtype TLSSt a = TLSSt { runTLSSt :: ErrT TLSError (State TLSState) a } +newtype TLSSt a = TLSSt {runTLSSt :: ErrT TLSError (State TLSState) a} deriving (Monad, MonadError TLSError, Functor, Applicative) instance MonadState TLSState TLSSt where put x = TLSSt (lift $ put x) - get = TLSSt (lift get) + get = TLSSt (lift get) state f = TLSSt (lift $ state f) runTLSState :: TLSSt a -> TLSState -> (Either TLSError a, TLSState) runTLSState f st = runState (runErrT (runTLSSt f)) st newTLSState :: StateRNG -> Role -> TLSState -newTLSState rng clientContext = TLSState - { stSession = Session Nothing - , stSessionResuming = False - , stSecureRenegotiation = False - , stClientVerifiedData = B.empty - , stServerVerifiedData = B.empty - , stExtensionALPN = False - , stHandshakeRecordCont = Nothing - , stHandshakeRecordCont13 = Nothing - , stNegotiatedProtocol = Nothing - , stClientALPNSuggest = Nothing - , stClientGroupSuggest = Nothing - , stClientEcPointFormatSuggest = Nothing - , stClientCertificateChain = Nothing - , stClientSNI = Nothing - , stRandomGen = rng - , stVersion = Nothing - , stClientContext = clientContext - , stTLS13KeyShare = Nothing - , stTLS13PreSharedKey = Nothing - , stTLS13HRR = False - , stTLS13Cookie = Nothing - , stExporterMasterSecret = Nothing - , stClientSupportsPHA = False - } +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 + , stClientALPNSuggest = Nothing + , stClientGroupSuggest = Nothing + , stClientEcPointFormatSuggest = Nothing + , stClientCertificateChain = Nothing + , stClientSNI = Nothing + , stRandomGen = rng + , stVersion = Nothing + , stClientContext = clientContext + , stTLS13KeyShare = Nothing + , stTLS13PreSharedKey = Nothing + , stTLS13HRR = False + , stTLS13Cookie = Nothing + , stExporterSecret = Nothing + , stClientSupportsPHA = False + , stTLS12SessionTicket = Nothing + } -updateVerifiedData :: Role -> ByteString -> TLSSt () -updateVerifiedData sending bs = do - cc <- isClientContext - if cc /= sending - then modify (\st -> st { stServerVerifiedData = bs }) - else modify (\st -> st { stClientVerifiedData = bs }) +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}) -finishHandshakeTypeMaterial :: HandshakeType -> Bool -finishHandshakeTypeMaterial HandshakeType_ClientHello = True -finishHandshakeTypeMaterial HandshakeType_ServerHello = True -finishHandshakeTypeMaterial HandshakeType_Certificate = True -finishHandshakeTypeMaterial HandshakeType_HelloRequest = False -finishHandshakeTypeMaterial HandshakeType_ServerHelloDone = True -finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True -finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True -finishHandshakeTypeMaterial HandshakeType_CertRequest = True -finishHandshakeTypeMaterial HandshakeType_CertVerify = True -finishHandshakeTypeMaterial HandshakeType_Finished = True +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}) -finishHandshakeMaterial :: Handshake -> Bool -finishHandshakeMaterial = finishHandshakeTypeMaterial . typeOfHandshake +finishedHandshakeTypeMaterial :: HandshakeType -> Bool +finishedHandshakeTypeMaterial HandshakeType_ClientHello = True +finishedHandshakeTypeMaterial HandshakeType_ServerHello = True +finishedHandshakeTypeMaterial HandshakeType_Certificate = True +-- finishedHandshakeTypeMaterial HandshakeType_HelloRequest = False +finishedHandshakeTypeMaterial HandshakeType_ServerHelloDone = True +finishedHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True +finishedHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True +finishedHandshakeTypeMaterial HandshakeType_CertRequest = True +finishedHandshakeTypeMaterial HandshakeType_CertVerify = True +finishedHandshakeTypeMaterial HandshakeType_NewSessionTicket = True +finishedHandshakeTypeMaterial HandshakeType_Finished = True +finishedHandshakeTypeMaterial _ = False +finishedHandshakeMaterial :: Handshake -> Bool +finishedHandshakeMaterial = finishedHandshakeTypeMaterial . typeOfHandshake + certVerifyHandshakeTypeMaterial :: HandshakeType -> Bool -certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True -certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True -certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True -certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False +certVerifyHandshakeTypeMaterial HandshakeType_ClientHello = True +certVerifyHandshakeTypeMaterial HandshakeType_ServerHello = True +certVerifyHandshakeTypeMaterial HandshakeType_Certificate = True +-- certVerifyHandshakeTypeMaterial HandshakeType_HelloRequest = False certVerifyHandshakeTypeMaterial HandshakeType_ServerHelloDone = True -certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True -certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True -certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True -certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False -certVerifyHandshakeTypeMaterial HandshakeType_Finished = False +certVerifyHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True +certVerifyHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True +certVerifyHandshakeTypeMaterial HandshakeType_CertRequest = True +-- certVerifyHandshakeTypeMaterial HandshakeType_CertVerify = False +-- certVerifyHandshakeTypeMaterial HandshakeType_Finished = False +certVerifyHandshakeTypeMaterial _ = False certVerifyHandshakeMaterial :: Handshake -> Bool certVerifyHandshakeMaterial = certVerifyHandshakeTypeMaterial . typeOfHandshake setSession :: Session -> Bool -> TLSSt () -setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming }) +setSession session resuming = modify (\st -> st{stSession = session, stSessionResuming = resuming}) getSession :: TLSSt Session getSession = gets stSession @@ -186,68 +207,101 @@ isSessionResuming = gets stSessionResuming 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 - where maybeSet st = case stVersion st of - Nothing -> st { stVersion = Just ver } - Just _ -> st + where + maybeSet st = case stVersion st of + Nothing -> st{stVersion = Just ver} + Just _ -> st getVersion :: TLSSt Version -getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion +getVersion = + fromMaybe (error "internal error: version hasn't been set yet") + <$> gets stVersion getVersionWithDefault :: Version -> TLSSt Version 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 s = modify (\st -> st{stNegotiatedProtocol = Just s}) getNegotiatedProtocol :: TLSSt (Maybe B.ByteString) getNegotiatedProtocol = gets stNegotiatedProtocol setClientALPNSuggest :: [B.ByteString] -> TLSSt () -setClientALPNSuggest ps = modify (\st -> st { stClientALPNSuggest = Just ps}) +setClientALPNSuggest ps = modify (\st -> st{stClientALPNSuggest = Just ps}) getClientALPNSuggest :: TLSSt (Maybe [B.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}) + +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}) getClientSNI :: TLSSt (Maybe HostName) getClientSNI = gets stClientSNI -getVerifiedData :: Role -> TLSSt ByteString -getVerifiedData client = gets (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) +getVerifyData :: Role -> TLSSt ByteString +getVerifyData client = do + mVerifyData <- + gets (if client == ClientRole then stClientVerifyData else stServerVerifyData) + return $ fromMaybe "" mVerifyData -isClientContext :: TLSSt Role -isClientContext = gets stClientContext +getMyVerifyData :: TLSSt (Maybe ByteString) +getMyVerifyData = do + role <- getRole + if role == ClientRole + then gets stClientVerifyData + else gets stServerVerifyData +getPeerVerifyData :: TLSSt (Maybe ByteString) +getPeerVerifyData = do + role <- getRole + if role == ClientRole + then gets stServerVerifyData + else gets stClientVerifyData + +getFirstVerifyData :: TLSSt (Maybe ByteString) +getFirstVerifyData = do + resuming <- isSessionResuming + if resuming + then gets stServerVerifyData + else gets stClientVerifyData + +getRole :: TLSSt Role +getRole = gets stClientContext + genRandom :: Int -> TLSSt ByteString genRandom n = do withRNG (getRandomBytes n) @@ -255,42 +309,48 @@ withRNG :: MonadPseudoRandom StateRNG a -> TLSSt a withRNG f = do st <- get - let (a,rng') = withTLSRNG (stRandomGen st) f - put (st { stRandomGen = rng' }) + let (a, rng') = withTLSRNG (stRandomGen st) f + put (st{stRandomGen = rng'}) return a -setExporterMasterSecret :: ByteString -> TLSSt () -setExporterMasterSecret key = modify (\st -> st { stExporterMasterSecret = Just key }) +setExporterSecret :: ByteString -> TLSSt () +setExporterSecret key = modify (\st -> st{stExporterSecret = Just key}) -getExporterMasterSecret :: TLSSt (Maybe ByteString) -getExporterMasterSecret = gets stExporterMasterSecret +getExporterSecret :: TLSSt (Maybe ByteString) +getExporterSecret = gets stExporterSecret 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 }) +setClientSupportsPHA b = modify (\st -> st{stClientSupportsPHA = b}) getClientSupportsPHA :: TLSSt Bool getClientSupportsPHA = gets stClientSupportsPHA + +setTLS12SessionTicket :: Ticket -> TLSSt () +setTLS12SessionTicket t = modify (\st -> st{stTLS12SessionTicket = Just t}) + +getTLS12SessionTicket :: TLSSt (Maybe Ticket) +getTLS12SessionTicket = gets stTLS12SessionTicket diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -1,692 +1,920 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | --- Module : Network.TLS.Struct --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the Struct module contains all definitions and values of the TLS protocol --- -module Network.TLS.Struct - ( Version(..) - , ConnectionEnd(..) - , CipherType(..) - , CipherData(..) - , ExtensionID - , ExtensionRaw(..) - , CertificateType(..) - , lastSupportedCertificateType - , HashAlgorithm(..) - , SignatureAlgorithm(..) - , HashAndSignatureAlgorithm - , DigitallySigned(..) - , Signature - , ProtocolType(..) - , TLSError(..) - , TLSException(..) - , DistinguishedName - , BigNum(..) - , bigNumToInteger - , bigNumFromInteger - , ServerDHParams(..) - , serverDHParamsToParams - , serverDHParamsToPublic - , serverDHParamsFrom - , ServerECDHParams(..) - , ServerRSAParams(..) - , ServerKeyXchgAlgorithmData(..) - , ClientKeyXchgAlgorithmData(..) - , Packet(..) - , Header(..) - , ServerRandom(..) - , ClientRandom(..) - , FinishedData - , SessionID - , Session(..) - , SessionData(..) - , AlertLevel(..) - , AlertDescription(..) - , HandshakeType(..) - , Handshake(..) - , numericalVer - , verOfNum - , TypeValuable, valOfType, valToType - , EnumSafe8(..) - , EnumSafe16(..) - , packetType - , typeOfHandshake - ) where - -import Data.X509 (CertificateChain, DistinguishedName) -import Data.Typeable -import Control.Exception (Exception(..)) -import Network.TLS.Types -import Network.TLS.Crypto -import Network.TLS.Util.Serialization -import Network.TLS.Imports - -data ConnectionEnd = ConnectionServer | ConnectionClient -data CipherType = CipherStream | CipherBlock | CipherAEAD - -data CipherData = CipherData - { cipherDataContent :: ByteString - , cipherDataMAC :: Maybe ByteString - , cipherDataPadding :: Maybe (ByteString, Int) - } deriving (Show,Eq) - --- | Some of the IANA registered code points for 'CertificateType' are not --- currently supported by the library. Nor should they be, they're are either --- unwise, obsolete or both. There's no point in conveying these to the user --- in the client certificate request callback. The request callback will be --- filtered to exclude unsupported values. If the user cannot find a certificate --- for a supported code point, we'll go ahead without a client certificate and --- hope for the best, unless the user's callback decides to throw an exception. --- -data CertificateType = - CertificateType_RSA_Sign -- ^ TLS10 and up, RFC5246 - | CertificateType_DSS_Sign -- ^ TLS10 and up, RFC5246 - | CertificateType_ECDSA_Sign -- ^ TLS10 and up, RFC8422 - | CertificateType_Ed25519_Sign -- ^ TLS13 and up, synthetic - | CertificateType_Ed448_Sign -- ^ TLS13 and up, synthetic - -- | None of the below will ever be presented to the callback. Any future - -- public key algorithms valid for client certificates go above this line. - | CertificateType_RSA_Fixed_DH -- Obsolete, unsupported - | CertificateType_DSS_Fixed_DH -- Obsolete, unsupported - | CertificateType_RSA_Ephemeral_DH -- Obsolete, unsupported - | CertificateType_DSS_Ephemeral_DH -- Obsolete, unsupported - | CertificateType_fortezza_dms -- Obsolete, unsupported - | CertificateType_RSA_Fixed_ECDH -- Obsolete, unsupported - | CertificateType_ECDSA_Fixed_ECDH -- Obsolete, unsupported - | CertificateType_Unknown Word8 -- Obsolete, unsupported - deriving (Eq, Ord, Show) - --- | Last supported certificate type, no 'CertificateType that --- compares greater than this one (based on the 'Ord' instance, --- not on the wire code point) will be reported to the application --- via the client certificate request callback. --- -lastSupportedCertificateType :: CertificateType -lastSupportedCertificateType = CertificateType_ECDSA_Sign - - -data HashAlgorithm = - HashNone - | HashMD5 - | HashSHA1 - | HashSHA224 - | HashSHA256 - | HashSHA384 - | HashSHA512 - | HashIntrinsic - | HashOther Word8 - deriving (Show,Eq) - -data SignatureAlgorithm = - SignatureAnonymous - | SignatureRSA - | SignatureDSS - | SignatureECDSA - | SignatureRSApssRSAeSHA256 - | SignatureRSApssRSAeSHA384 - | SignatureRSApssRSAeSHA512 - | SignatureEd25519 - | SignatureEd448 - | SignatureRSApsspssSHA256 - | SignatureRSApsspssSHA384 - | SignatureRSApsspssSHA512 - | SignatureOther Word8 - deriving (Show,Eq) - -type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) - ------------------------------------------------------------- - -type Signature = ByteString - -data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature - deriving (Show,Eq) - -data ProtocolType = - ProtocolType_ChangeCipherSpec - | ProtocolType_Alert - | ProtocolType_Handshake - | ProtocolType_AppData - | ProtocolType_DeprecatedHandshake - deriving (Eq, Show) - --- | 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 = - Error_Misc String -- ^ mainly for instance of Error - | Error_Protocol String AlertDescription - -- ^ A fatal error condition was encountered at a low level. The - -- elements of the tuple give (freeform text description, structured - -- error description). - | Error_Protocol_Warning 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_Certificate String - | Error_HandshakePolicy String -- ^ handshake policy failed. - | 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 = - Terminated Bool String TLSError - -- ^ Early termination exception with the reason and the error associated - | HandshakeFailed TLSError - -- ^ Handshake failed for the reason attached. - | PostHandshake TLSError - -- ^ Failure occurred while sending or receiving data after the - -- TLS handshake succeeded. - | Uncontextualized TLSError - -- ^ Lifts a 'TLSError' into 'TLSException' without provided any context - -- around when the error happened. - | ConnectionNotEstablished - -- ^ 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. - | MissingHandshake - -- ^ Expected that a TLS handshake had already taken place, but no TLS - -- handshake had occurred. - -- Indicates that this library has been used incorrectly. - deriving (Show,Eq,Typeable) - -instance Exception TLSException - -data Packet = - Handshake [Handshake] - | Alert [(AlertLevel, AlertDescription)] - | ChangeCipherSpec - | AppData ByteString - deriving (Show,Eq) - -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) - -type FinishedData = ByteString - --- | Identifier of a TLS extension. -type ExtensionID = Word16 - --- | The raw content of a TLS extension. -data ExtensionRaw = ExtensionRaw ExtensionID ByteString - deriving (Eq) - -instance Show ExtensionRaw where - show (ExtensionRaw eid bs) = "ExtensionRaw " ++ showEID eid ++ " " ++ showBytesHex bs - -showEID :: ExtensionID -> String -showEID 0x0 = "ServerName" -showEID 0x1 = "MaxFragmentLength" -showEID 0x2 = "ClientCertificateUrl" -showEID 0x3 = "TrustedCAKeys" -showEID 0x4 = "TruncatedHMAC" -showEID 0x5 = "StatusRequest" -showEID 0x6 = "UserMapping" -showEID 0x7 = "ClientAuthz" -showEID 0x8 = "ServerAuthz" -showEID 0x9 = "CertType" -showEID 0xa = "NegotiatedGroups" -showEID 0xb = "EcPointFormats" -showEID 0xc = "SRP" -showEID 0xd = "SignatureAlgorithm" -showEID 0xe = "SRTP" -showEID 0xf = "Heartbeat" -showEID 0x10 = "ApplicationLayerProtocolNegotiation" -showEID 0x11 = "StatusRequestv2" -showEID 0x12 = "SignedCertificateTimestamp" -showEID 0x13 = "ClientCertificateType" -showEID 0x14 = "ServerCertificateType" -showEID 0x15 = "Padding" -showEID 0x16 = "EncryptThenMAC" -showEID 0x17 = "ExtendedMasterSecret" -showEID 0x23 = "SessionTicket" -showEID 0x29 = "PreShardeKey" -showEID 0x2a = "EarlyData" -showEID 0x2b = "SupportedVersions" -showEID 0x2c = "Cookie" -showEID 0x2d = "PskKeyExchangeModes" -showEID 0x2f = "CertificateAuthorities" -showEID 0x30 = "OidFilters" -showEID 0x31 = "PostHandshakeAuth" -showEID 0x32 = "SignatureAlgorithmsCert" -showEID 0x33 = "KeyShare" -showEID 0x39 = "QuicTransportParameters" -showEID 0xff01 = "SecureRenegotiation" -showEID 0xffa5 = "QuicTransportParameters" -showEID x = show x - -data AlertLevel = - AlertLevel_Warning - | AlertLevel_Fatal - deriving (Show,Eq) - -data AlertDescription = - CloseNotify - | UnexpectedMessage - | BadRecordMac - | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation - | RecordOverflow - | DecompressionFailure - | HandshakeFailure - | BadCertificate - | UnsupportedCertificate - | CertificateRevoked - | CertificateExpired - | CertificateUnknown - | IllegalParameter - | UnknownCa - | AccessDenied - | DecodeError - | DecryptError - | ExportRestriction - | ProtocolVersion - | InsufficientSecurity - | InternalError - | InappropriateFallback -- RFC7507 - | UserCanceled - | NoRenegotiation - | MissingExtension - | UnsupportedExtension - | CertificateUnobtainable - | UnrecognizedName - | BadCertificateStatusResponse - | BadCertificateHashValue - | UnknownPskIdentity - | CertificateRequired - | NoApplicationProtocol -- RFC7301 - deriving (Show,Eq) - -data HandshakeType = - HandshakeType_HelloRequest - | HandshakeType_ClientHello - | HandshakeType_ServerHello - | HandshakeType_Certificate - | HandshakeType_ServerKeyXchg - | HandshakeType_CertRequest - | HandshakeType_ServerHelloDone - | HandshakeType_CertVerify - | HandshakeType_ClientKeyXchg - | HandshakeType_Finished - deriving (Show,Eq) - -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 - , serverDHParams_y :: BigNum - } deriving (Show,Eq) - -serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams -serverDHParamsFrom params dhPub = - ServerDHParams (bigNumFromInteger $ dhParamsGetP params) - (bigNumFromInteger $ dhParamsGetG params) - (bigNumFromInteger $ dhUnwrapPublic dhPub) - -serverDHParamsToParams :: ServerDHParams -> DHParams -serverDHParamsToParams serverParams = - dhParams (bigNumToInteger $ serverDHParams_p serverParams) - (bigNumToInteger $ serverDHParams_g serverParams) - -serverDHParamsToPublic :: ServerDHParams -> DHPublic -serverDHParamsToPublic serverParams = - dhPublic (bigNumToInteger $ serverDHParams_y serverParams) - -data ServerECDHParams = ServerECDHParams Group GroupPublic - deriving (Show,Eq) - -data ServerRSAParams = ServerRSAParams - { rsa_modulus :: Integer - , rsa_exponent :: Integer - } deriving (Show,Eq) - -data ServerKeyXchgAlgorithmData = - SKX_DH_Anon ServerDHParams - | SKX_DHE_DSS ServerDHParams DigitallySigned - | SKX_DHE_RSA ServerDHParams DigitallySigned - | SKX_ECDHE_RSA ServerECDHParams DigitallySigned - | SKX_ECDHE_ECDSA ServerECDHParams DigitallySigned - | SKX_RSA (Maybe ServerRSAParams) - | SKX_DH_DSS (Maybe ServerRSAParams) - | 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) - -data ClientKeyXchgAlgorithmData = - CKX_RSA ByteString - | CKX_DH DHPublic - | CKX_ECDH ByteString - deriving (Show,Eq) - -type DeprecatedRecord = ByteString - -data Handshake = - ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) - | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] - | Certificates CertificateChain - | HelloRequest - | ServerHelloDone - | ClientKeyXchg ClientKeyXchgAlgorithmData - | ServerKeyXchg ServerKeyXchgAlgorithmData - | CertRequest [CertificateType] (Maybe [HashAndSignatureAlgorithm]) [DistinguishedName] - | CertVerify DigitallySigned - | Finished FinishedData - deriving (Show,Eq) - -packetType :: Packet -> ProtocolType -packetType (Handshake _) = ProtocolType_Handshake -packetType (Alert _) = ProtocolType_Alert -packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec -packetType (AppData _) = ProtocolType_AppData - -typeOfHandshake :: Handshake -> HandshakeType -typeOfHandshake ClientHello{} = HandshakeType_ClientHello -typeOfHandshake ServerHello{} = HandshakeType_ServerHello -typeOfHandshake Certificates{} = HandshakeType_Certificate -typeOfHandshake HelloRequest = HandshakeType_HelloRequest -typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone -typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg -typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg -typeOfHandshake CertRequest{} = HandshakeType_CertRequest -typeOfHandshake CertVerify{} = HandshakeType_CertVerify -typeOfHandshake Finished{} = HandshakeType_Finished - -numericalVer :: Version -> (Word8, Word8) -numericalVer SSL2 = (2, 0) -numericalVer SSL3 = (3, 0) -numericalVer TLS10 = (3, 1) -numericalVer TLS11 = (3, 2) -numericalVer TLS12 = (3, 3) -numericalVer TLS13 = (3, 4) - -verOfNum :: (Word8, Word8) -> Maybe Version -verOfNum (2, 0) = Just SSL2 -verOfNum (3, 0) = Just SSL3 -verOfNum (3, 1) = Just TLS10 -verOfNum (3, 2) = Just TLS11 -verOfNum (3, 3) = Just TLS12 -verOfNum (3, 4) = Just TLS13 -verOfNum _ = Nothing - -class TypeValuable a where - valOfType :: a -> Word8 - valToType :: Word8 -> Maybe a - --- a better name for TypeValuable -class EnumSafe8 a where - fromEnumSafe8 :: a -> Word8 - toEnumSafe8 :: Word8 -> Maybe a - -class EnumSafe16 a where - fromEnumSafe16 :: a -> Word16 - toEnumSafe16 :: Word16 -> Maybe a - -instance TypeValuable ConnectionEnd where - valOfType ConnectionServer = 0 - valOfType ConnectionClient = 1 - - valToType 0 = Just ConnectionServer - valToType 1 = Just ConnectionClient - valToType _ = Nothing - -instance TypeValuable CipherType where - valOfType CipherStream = 0 - valOfType CipherBlock = 1 - valOfType CipherAEAD = 2 - - valToType 0 = Just CipherStream - valToType 1 = Just CipherBlock - valToType 2 = Just CipherAEAD - valToType _ = Nothing - -instance TypeValuable ProtocolType where - valOfType ProtocolType_ChangeCipherSpec = 20 - valOfType ProtocolType_Alert = 21 - valOfType ProtocolType_Handshake = 22 - valOfType ProtocolType_AppData = 23 - valOfType ProtocolType_DeprecatedHandshake = 128 -- unused - - valToType 20 = Just ProtocolType_ChangeCipherSpec - valToType 21 = Just ProtocolType_Alert - valToType 22 = Just ProtocolType_Handshake - valToType 23 = Just ProtocolType_AppData - valToType _ = Nothing - -instance TypeValuable HandshakeType where - valOfType HandshakeType_HelloRequest = 0 - valOfType HandshakeType_ClientHello = 1 - valOfType HandshakeType_ServerHello = 2 - valOfType HandshakeType_Certificate = 11 - valOfType HandshakeType_ServerKeyXchg = 12 - valOfType HandshakeType_CertRequest = 13 - valOfType HandshakeType_ServerHelloDone = 14 - valOfType HandshakeType_CertVerify = 15 - valOfType HandshakeType_ClientKeyXchg = 16 - valOfType HandshakeType_Finished = 20 - - valToType 0 = Just HandshakeType_HelloRequest - valToType 1 = Just HandshakeType_ClientHello - valToType 2 = Just HandshakeType_ServerHello - valToType 11 = Just HandshakeType_Certificate - valToType 12 = Just HandshakeType_ServerKeyXchg - valToType 13 = Just HandshakeType_CertRequest - valToType 14 = Just HandshakeType_ServerHelloDone - valToType 15 = Just HandshakeType_CertVerify - valToType 16 = Just HandshakeType_ClientKeyXchg - valToType 20 = Just HandshakeType_Finished - valToType _ = Nothing - -instance TypeValuable AlertLevel where - valOfType AlertLevel_Warning = 1 - valOfType AlertLevel_Fatal = 2 - - valToType 1 = Just AlertLevel_Warning - valToType 2 = Just AlertLevel_Fatal - valToType _ = Nothing - -instance TypeValuable AlertDescription where - valOfType CloseNotify = 0 - valOfType UnexpectedMessage = 10 - valOfType BadRecordMac = 20 - valOfType DecryptionFailed = 21 - valOfType RecordOverflow = 22 - valOfType DecompressionFailure = 30 - valOfType HandshakeFailure = 40 - valOfType BadCertificate = 42 - valOfType UnsupportedCertificate = 43 - valOfType CertificateRevoked = 44 - valOfType CertificateExpired = 45 - valOfType CertificateUnknown = 46 - valOfType IllegalParameter = 47 - valOfType UnknownCa = 48 - valOfType AccessDenied = 49 - valOfType DecodeError = 50 - valOfType DecryptError = 51 - valOfType ExportRestriction = 60 - valOfType ProtocolVersion = 70 - valOfType InsufficientSecurity = 71 - valOfType InternalError = 80 - valOfType InappropriateFallback = 86 - valOfType UserCanceled = 90 - valOfType NoRenegotiation = 100 - valOfType MissingExtension = 109 - valOfType UnsupportedExtension = 110 - valOfType CertificateUnobtainable = 111 - valOfType UnrecognizedName = 112 - valOfType BadCertificateStatusResponse = 113 - valOfType BadCertificateHashValue = 114 - valOfType UnknownPskIdentity = 115 - valOfType CertificateRequired = 116 - valOfType NoApplicationProtocol = 120 - - valToType 0 = Just CloseNotify - valToType 10 = Just UnexpectedMessage - valToType 20 = Just BadRecordMac - valToType 21 = Just DecryptionFailed - valToType 22 = Just RecordOverflow - valToType 30 = Just DecompressionFailure - valToType 40 = Just HandshakeFailure - valToType 42 = Just BadCertificate - valToType 43 = Just UnsupportedCertificate - valToType 44 = Just CertificateRevoked - valToType 45 = Just CertificateExpired - valToType 46 = Just CertificateUnknown - valToType 47 = Just IllegalParameter - valToType 48 = Just UnknownCa - valToType 49 = Just AccessDenied - valToType 50 = Just DecodeError - valToType 51 = Just DecryptError - valToType 60 = Just ExportRestriction - valToType 70 = Just ProtocolVersion - valToType 71 = Just InsufficientSecurity - valToType 80 = Just InternalError - valToType 86 = Just InappropriateFallback - valToType 90 = Just UserCanceled - valToType 100 = Just NoRenegotiation - valToType 109 = Just MissingExtension - valToType 110 = Just UnsupportedExtension - valToType 111 = Just CertificateUnobtainable - valToType 112 = Just UnrecognizedName - valToType 113 = Just BadCertificateStatusResponse - valToType 114 = Just BadCertificateHashValue - valToType 115 = Just UnknownPskIdentity - valToType 116 = Just CertificateRequired - valToType 120 = Just NoApplicationProtocol - valToType _ = Nothing - -instance TypeValuable CertificateType where - valOfType CertificateType_RSA_Sign = 1 - valOfType CertificateType_ECDSA_Sign = 64 - valOfType CertificateType_DSS_Sign = 2 - valOfType CertificateType_RSA_Fixed_DH = 3 - valOfType CertificateType_DSS_Fixed_DH = 4 - valOfType CertificateType_RSA_Ephemeral_DH = 5 - valOfType CertificateType_DSS_Ephemeral_DH = 6 - valOfType CertificateType_fortezza_dms = 20 - valOfType CertificateType_RSA_Fixed_ECDH = 65 - valOfType CertificateType_ECDSA_Fixed_ECDH = 66 - valOfType (CertificateType_Unknown i) = i - -- | There are no code points that map to the below synthetic types, these - -- are inferred indirectly from the @signature_algorithms@ extension of the - -- TLS 1.3 @CertificateRequest@ message. the value assignments are there - -- only to avoid partial function warnings. - valOfType CertificateType_Ed25519_Sign = 0 - valOfType CertificateType_Ed448_Sign = 0 - - valToType 1 = Just CertificateType_RSA_Sign - valToType 2 = Just CertificateType_DSS_Sign - valToType 3 = Just CertificateType_RSA_Fixed_DH - valToType 4 = Just CertificateType_DSS_Fixed_DH - valToType 5 = Just CertificateType_RSA_Ephemeral_DH - valToType 6 = Just CertificateType_DSS_Ephemeral_DH - valToType 20 = Just CertificateType_fortezza_dms - valToType 64 = Just CertificateType_ECDSA_Sign - valToType 65 = Just CertificateType_RSA_Fixed_ECDH - valToType 66 = Just CertificateType_ECDSA_Fixed_ECDH - valToType i = Just (CertificateType_Unknown i) - -- | There are no code points that map to the below synthetic types, these - -- are inferred indirectly from the @signature_algorithms@ extension of the - -- TLS 1.3 @CertificateRequest@ message. - -- @ - -- CertificateType_Ed25519_Sign - -- CertificateType_Ed448_Sign - -- @ - -instance TypeValuable HashAlgorithm where - valOfType HashNone = 0 - valOfType HashMD5 = 1 - valOfType HashSHA1 = 2 - valOfType HashSHA224 = 3 - valOfType HashSHA256 = 4 - valOfType HashSHA384 = 5 - valOfType HashSHA512 = 6 - valOfType HashIntrinsic = 8 - valOfType (HashOther i) = i - - valToType 0 = Just HashNone - valToType 1 = Just HashMD5 - valToType 2 = Just HashSHA1 - valToType 3 = Just HashSHA224 - valToType 4 = Just HashSHA256 - valToType 5 = Just HashSHA384 - valToType 6 = Just HashSHA512 - valToType 8 = Just HashIntrinsic - valToType i = Just (HashOther i) - -instance TypeValuable SignatureAlgorithm where - valOfType SignatureAnonymous = 0 - valOfType SignatureRSA = 1 - valOfType SignatureDSS = 2 - valOfType SignatureECDSA = 3 - valOfType SignatureRSApssRSAeSHA256 = 4 - valOfType SignatureRSApssRSAeSHA384 = 5 - valOfType SignatureRSApssRSAeSHA512 = 6 - valOfType SignatureEd25519 = 7 - valOfType SignatureEd448 = 8 - valOfType SignatureRSApsspssSHA256 = 9 - valOfType SignatureRSApsspssSHA384 = 10 - valOfType SignatureRSApsspssSHA512 = 11 - valOfType (SignatureOther i) = i - - valToType 0 = Just SignatureAnonymous - valToType 1 = Just SignatureRSA - valToType 2 = Just SignatureDSS - valToType 3 = Just SignatureECDSA - valToType 4 = Just SignatureRSApssRSAeSHA256 - valToType 5 = Just SignatureRSApssRSAeSHA384 - valToType 6 = Just SignatureRSApssRSAeSHA512 - valToType 7 = Just SignatureEd25519 - valToType 8 = Just SignatureEd448 - valToType 9 = Just SignatureRSApsspssSHA256 - valToType 10 = Just SignatureRSApsspssSHA384 - valToType 11 = Just SignatureRSApsspssSHA512 - valToType i = Just (SignatureOther i) - -instance EnumSafe16 Group where - fromEnumSafe16 P256 = 23 - fromEnumSafe16 P384 = 24 - fromEnumSafe16 P521 = 25 - fromEnumSafe16 X25519 = 29 - fromEnumSafe16 X448 = 30 - fromEnumSafe16 FFDHE2048 = 256 - fromEnumSafe16 FFDHE3072 = 257 - fromEnumSafe16 FFDHE4096 = 258 - fromEnumSafe16 FFDHE6144 = 259 - fromEnumSafe16 FFDHE8192 = 260 - - toEnumSafe16 23 = Just P256 - toEnumSafe16 24 = Just P384 - toEnumSafe16 25 = Just P521 - toEnumSafe16 29 = Just X25519 - toEnumSafe16 30 = Just X448 - toEnumSafe16 256 = Just FFDHE2048 - toEnumSafe16 257 = Just FFDHE3072 - toEnumSafe16 258 = Just FFDHE4096 - toEnumSafe16 259 = Just FFDHE6144 - toEnumSafe16 260 = Just FFDHE8192 - toEnumSafe16 _ = Nothing +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | The Struct module contains all definitions and values of the TLS +-- protocol. +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, + CertificateType_DSA_Sign, + CertificateType_ECDSA_Sign, + CertificateType_Ed25519_Sign, + CertificateType_Ed448_Sign + ), + 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 ( + .., + ProtocolType_ChangeCipherSpec, + ProtocolType_Alert, + ProtocolType_Handshake, + ProtocolType_AppData + ), + TLSError (..), + TLSException (..), + DistinguishedName, + BigNum (..), + bigNumToInteger, + bigNumFromInteger, + ServerDHParams (..), + serverDHParamsToParams, + serverDHParamsToPublic, + serverDHParamsFrom, + ServerECDHParams (..), + ServerRSAParams (..), + ServerKeyXchgAlgorithmData (..), + ClientKeyXchgAlgorithmData (..), + Packet (..), + Header (..), + ServerRandom (..), + ClientRandom (..), + FinishedData, + VerifyData, + SessionID, + Session (..), + SessionData (..), + AlertLevel ( + .., + AlertLevel_Warning, + AlertLevel_Fatal + ), + AlertDescription ( + .., + CloseNotify, + UnexpectedMessage, + BadRecordMac, + DecryptionFailed, + RecordOverflow, + DecompressionFailure, + HandshakeFailure, + BadCertificate, + UnsupportedCertificate, + CertificateRevoked, + CertificateExpired, + CertificateUnknown, + IllegalParameter, + UnknownCa, + AccessDenied, + DecodeError, + DecryptError, + ExportRestriction, + ProtocolVersion, + InsufficientSecurity, + InternalError, + InappropriateFallback, + UserCanceled, + NoRenegotiation, + MissingExtension, + UnsupportedExtension, + CertificateUnobtainable, + UnrecognizedName, + BadCertificateStatusResponse, + BadCertificateHashValue, + UnknownPskIdentity, + CertificateRequired, + NoApplicationProtocol + ), + HandshakeType ( + .., + HandshakeType_HelloRequest, + HandshakeType_ClientHello, + HandshakeType_ServerHello, + HandshakeType_NewSessionTicket, + HandshakeType_EndOfEarlyData, + HandshakeType_EncryptedExtensions, + HandshakeType_Certificate, + HandshakeType_ServerKeyXchg, + HandshakeType_CertRequest, + HandshakeType_ServerHelloDone, + HandshakeType_CertVerify, + HandshakeType_ClientKeyXchg, + HandshakeType_Finished, + HandshakeType_KeyUpdate + ), + Handshake (..), + CH (..), + packetType, + typeOfHandshake, +) where + +import Control.Exception (Exception (..)) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as C8 +import Data.Typeable +import Data.X509 (CertificateChain, DistinguishedName) +import Network.TLS.Crypto +import Network.TLS.Imports +import Network.TLS.Types +import Network.TLS.Util.Serialization + +---------------------------------------------------------------- + +data CipherData = CipherData + { cipherDataContent :: ByteString + , cipherDataMAC :: Maybe ByteString + , cipherDataPadding :: Maybe (ByteString, Int) + } + deriving (Show, Eq) + +---------------------------------------------------------------- + +-- | Some of the IANA registered code points for 'CertificateType' are not +-- currently supported by the library. Nor should they be, they're are either +-- unwise, obsolete or both. There's no point in conveying these to the user +-- in the client certificate request callback. The request callback will be +-- filtered to exclude unsupported values. If the user cannot find a certificate +-- for a supported code point, we'll go ahead without a client certificate and +-- hope for the best, unless the user's callback decides to throw an exception. +newtype CertificateType = CertificateType {fromCertificateType :: Word8} + deriving (Eq, Ord) + +{- FOURMOLU_DISABLE -} +-- | TLS10 and up, RFC5246 +pattern CertificateType_RSA_Sign :: CertificateType +pattern CertificateType_RSA_Sign = CertificateType 1 +-- | TLS10 and up, RFC5246 +pattern CertificateType_DSA_Sign :: CertificateType +pattern CertificateType_DSA_Sign = CertificateType 2 +-- | TLS10 and up, RFC8422 +pattern CertificateType_ECDSA_Sign :: CertificateType +pattern CertificateType_ECDSA_Sign = CertificateType 64 +-- \| There are no code points that map to the below synthetic types, these +-- are inferred indirectly from the @signature_algorithms@ extension of the +-- TLS 1.3 @CertificateRequest@ message. the value assignments are there +-- only to avoid partial function warnings. +pattern CertificateType_Ed25519_Sign :: CertificateType +pattern CertificateType_Ed25519_Sign = CertificateType 254 -- fixme: dummy value +pattern CertificateType_Ed448_Sign :: CertificateType +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 x) = "CertificateType " ++ show x +{- FOURMOLU_ENABLE -} + +-- | Last supported certificate type, no 'CertificateType that +-- compares greater than this one (based on the 'Ord' instance, +-- not on the wire code point) will be reported to the application +-- via the client certificate request callback. +lastSupportedCertificateType :: CertificateType +lastSupportedCertificateType = CertificateType_ECDSA_Sign + +------------------------------------------------------------ + +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) + +---------------------------------------------------------------- + +newtype ProtocolType = ProtocolType {fromProtocolType :: Word8} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern ProtocolType_ChangeCipherSpec :: ProtocolType +pattern ProtocolType_ChangeCipherSpec = ProtocolType 20 + +pattern ProtocolType_Alert :: ProtocolType +pattern ProtocolType_Alert = ProtocolType 21 + +pattern ProtocolType_Handshake :: ProtocolType +pattern ProtocolType_Handshake = ProtocolType 22 + +pattern ProtocolType_AppData :: ProtocolType +pattern ProtocolType_AppData = ProtocolType 23 + +instance Show ProtocolType where + show ProtocolType_ChangeCipherSpec = "ChangeCipherSpec" + show ProtocolType_Alert = "Alert" + show ProtocolType_Handshake = "Handshake" + show ProtocolType_AppData = "AppData" + show (ProtocolType x) = "ProtocolType " ++ show x +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +-- | TLSError that might be returned through the TLS stack. +-- +-- Prior to version 1.8.0, this type had an @Exception@ instance. +-- In version 1.8.0, this instance was removed, and functions in +-- this library now only throw 'TLSException'. +data TLSError + = -- | mainly for instance of Error + Error_Misc String + | -- | A fatal error condition was encountered at a low level. The + -- elements of the tuple give (freeform text description, structured + -- error description). + Error_Protocol String AlertDescription + | -- | A non-fatal error condition was encountered at a low level at a low + -- level. The elements of the tuple give (freeform text description, + -- structured error description). + Error_Protocol_Warning String AlertDescription + | Error_Certificate String + | -- | handshake policy failed. + Error_HandshakePolicy String + | Error_EOF + | Error_Packet String + | Error_Packet_unexpected String String + | Error_Packet_Parsing String + deriving (Eq, Show, Typeable) + +---------------------------------------------------------------- + +-- | TLS Exceptions. Some of the data constructors indicate incorrect use of +-- the library, and the documentation for those data constructors calls +-- this out. The others wrap 'TLSError' with some kind of context to explain +-- when the exception occurred. +data TLSException + = -- | Early termination exception with the reason and the error associated + Terminated Bool String TLSError + | -- | Handshake failed for the reason attached. + HandshakeFailed TLSError + | -- | Failure occurred while sending or receiving data after the + -- TLS handshake succeeded. + PostHandshake TLSError + | -- | Lifts a 'TLSError' into 'TLSException' without provided any context + -- around when the error happened. + Uncontextualized TLSError + | -- | Usage error when the connection has not been established + -- and the user is trying to send or receive data. + -- Indicates that this library has been used incorrectly. + ConnectionNotEstablished + | -- | Expected that a TLS handshake had already taken place, but no TLS + -- handshake had occurred. + -- Indicates that this library has been used incorrectly. + MissingHandshake + deriving (Show, Eq, Typeable) + +instance Exception TLSException + +---------------------------------------------------------------- + +data Packet + = Handshake [Handshake] + | Alert [(AlertLevel, AlertDescription)] + | ChangeCipherSpec + | AppData ByteString + deriving (Eq) + +instance Show Packet where + show (Handshake hs) = "Handshake " ++ show hs + show (Alert as) = "Alert " ++ show as + show ChangeCipherSpec = "ChangeCipherSpec" + show (AppData bs) = "AppData " ++ C8.unpack (B16.encode bs) + +data Header = Header ProtocolType Version Word16 deriving (Show, Eq) + +newtype ServerRandom = ServerRandom {unServerRandom :: ByteString} + deriving (Show, Eq) +newtype ClientRandom = ClientRandom {unClientRandom :: ByteString} + deriving (Show, Eq) +newtype Session = Session (Maybe SessionID) deriving (Show, Eq) + +{-# DEPRECATED FinishedData "use VerifyData" #-} +type FinishedData = ByteString +type VerifyData = ByteString + +---------------------------------------------------------------- + +-- | Identifier of a TLS extension. +-- +newtype ExtensionID = ExtensionID {fromExtensionID :: Word16} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern EID_ServerName :: ExtensionID -- RFC6066 +pattern EID_ServerName = ExtensionID 0x0 +pattern EID_MaxFragmentLength :: ExtensionID -- RFC6066 +pattern EID_MaxFragmentLength = ExtensionID 0x1 +pattern EID_ClientCertificateUrl :: ExtensionID -- RFC6066 +pattern EID_ClientCertificateUrl = ExtensionID 0x2 +pattern EID_TrustedCAKeys :: ExtensionID -- RFC6066 +pattern EID_TrustedCAKeys = ExtensionID 0x3 +pattern EID_TruncatedHMAC :: ExtensionID -- RFC6066 +pattern EID_TruncatedHMAC = ExtensionID 0x4 +pattern EID_StatusRequest :: ExtensionID -- RFC6066 +pattern EID_StatusRequest = ExtensionID 0x5 +pattern EID_UserMapping :: ExtensionID -- RFC4681 +pattern EID_UserMapping = ExtensionID 0x6 +pattern EID_ClientAuthz :: ExtensionID -- RFC5878 +pattern EID_ClientAuthz = ExtensionID 0x7 +pattern EID_ServerAuthz :: ExtensionID -- RFC5878 +pattern EID_ServerAuthz = ExtensionID 0x8 +pattern EID_CertType :: ExtensionID -- RFC6091 +pattern EID_CertType = ExtensionID 0x9 +pattern EID_SupportedGroups :: ExtensionID -- RFC8422,8446 +pattern EID_SupportedGroups = ExtensionID 0xa +pattern EID_EcPointFormats :: ExtensionID -- RFC4492 +pattern EID_EcPointFormats = ExtensionID 0xb +pattern EID_SRP :: ExtensionID -- RFC5054 +pattern EID_SRP = ExtensionID 0xc +pattern EID_SignatureAlgorithms :: ExtensionID -- RFC5246,8446 +pattern EID_SignatureAlgorithms = ExtensionID 0xd +pattern EID_SRTP :: ExtensionID -- RFC5764 +pattern EID_SRTP = ExtensionID 0xe +pattern EID_Heartbeat :: ExtensionID -- RFC6520 +pattern EID_Heartbeat = ExtensionID 0xf +pattern EID_ApplicationLayerProtocolNegotiation :: ExtensionID -- RFC7301 +pattern EID_ApplicationLayerProtocolNegotiation = ExtensionID 0x10 +pattern EID_StatusRequestv2 :: ExtensionID -- RFC6961 +pattern EID_StatusRequestv2 = ExtensionID 0x11 +pattern EID_SignedCertificateTimestamp :: ExtensionID -- RFC6962 +pattern EID_SignedCertificateTimestamp = ExtensionID 0x12 +pattern EID_ClientCertificateType :: ExtensionID -- RFC7250 +pattern EID_ClientCertificateType = ExtensionID 0x13 +pattern EID_ServerCertificateType :: ExtensionID -- RFC7250 +pattern EID_ServerCertificateType = ExtensionID 0x14 +pattern EID_Padding :: ExtensionID -- RFC5246 +pattern EID_Padding = ExtensionID 0x15 +pattern EID_EncryptThenMAC :: ExtensionID -- RFC7366 +pattern EID_EncryptThenMAC = ExtensionID 0x16 +pattern EID_ExtendedMainSecret :: ExtensionID -- REF7627 +pattern EID_ExtendedMainSecret = ExtensionID 0x17 +pattern EID_SessionTicket :: ExtensionID -- RFC4507 +pattern EID_SessionTicket = ExtensionID 0x23 +pattern EID_PreSharedKey :: ExtensionID -- RFC8446 +pattern EID_PreSharedKey = ExtensionID 0x29 +pattern EID_EarlyData :: ExtensionID -- RFC8446 +pattern EID_EarlyData = ExtensionID 0x2a +pattern EID_SupportedVersions :: ExtensionID -- RFC8446 +pattern EID_SupportedVersions = ExtensionID 0x2b +pattern EID_Cookie :: ExtensionID -- RFC8446 +pattern EID_Cookie = ExtensionID 0x2c +pattern EID_PskKeyExchangeModes :: ExtensionID -- RFC8446 +pattern EID_PskKeyExchangeModes = ExtensionID 0x2d +pattern EID_CertificateAuthorities :: ExtensionID -- RFC8446 +pattern EID_CertificateAuthorities = ExtensionID 0x2f +pattern EID_OidFilters :: ExtensionID -- RFC8446 +pattern EID_OidFilters = ExtensionID 0x30 +pattern EID_PostHandshakeAuth :: ExtensionID -- RFC8446 +pattern EID_PostHandshakeAuth = ExtensionID 0x31 +pattern EID_SignatureAlgorithmsCert :: ExtensionID -- RFC8446 +pattern EID_SignatureAlgorithmsCert = ExtensionID 0x32 +pattern EID_KeyShare :: ExtensionID -- RFC8446 +pattern EID_KeyShare = ExtensionID 0x33 +pattern EID_QuicTransportParameters :: ExtensionID -- RFC9001 +pattern EID_QuicTransportParameters = ExtensionID 0x39 +pattern EID_SecureRenegotiation :: ExtensionID -- RFC5746 +pattern EID_SecureRenegotiation = ExtensionID 0xff01 + +instance Show ExtensionID where + show EID_ServerName = "ServerName" + show EID_MaxFragmentLength = "MaxFragmentLength" + show EID_ClientCertificateUrl = "ClientCertificateUrl" + show EID_TrustedCAKeys = "TrustedCAKeys" + show EID_TruncatedHMAC = "TruncatedHMAC" + show EID_StatusRequest = "StatusRequest" + show EID_UserMapping = "UserMapping" + show EID_ClientAuthz = "ClientAuthz" + show EID_ServerAuthz = "ServerAuthz" + show EID_CertType = "CertType" + show EID_SupportedGroups = "SupportedGroups" + show EID_EcPointFormats = "EcPointFormats" + show EID_SRP = "SRP" + show EID_SignatureAlgorithms = "SignatureAlgorithms" + show EID_SRTP = "SRTP" + show EID_Heartbeat = "Heartbeat" + show EID_ApplicationLayerProtocolNegotiation = "ApplicationLayerProtocolNegotiation" + show EID_StatusRequestv2 = "StatusRequestv2" + show EID_SignedCertificateTimestamp = "SignedCertificateTimestamp" + show EID_ClientCertificateType = "ClientCertificateType" + show EID_ServerCertificateType = "ServerCertificateType" + show EID_Padding = "Padding" + show EID_EncryptThenMAC = "EncryptThenMAC" + show EID_ExtendedMainSecret = "ExtendedMainSecret" + show EID_SessionTicket = "SessionTicket" + show EID_PreSharedKey = "PreSharedKey" + show EID_EarlyData = "EarlyData" + show EID_SupportedVersions = "SupportedVersions" + show EID_Cookie = "Cookie" + show EID_PskKeyExchangeModes = "PskKeyExchangeModes" + show EID_CertificateAuthorities = "CertificateAuthorities" + show EID_OidFilters = "OidFilters" + show EID_PostHandshakeAuth = "PostHandshakeAuth" + show EID_SignatureAlgorithmsCert = "SignatureAlgorithmsCert" + show EID_KeyShare = "KeyShare" + show EID_QuicTransportParameters = "QuicTransportParameters" + show EID_SecureRenegotiation = "SecureRenegotiation" + show (ExtensionID x) = "ExtensionID " ++ show x +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +-- | The raw content of a TLS extension. +data ExtensionRaw = ExtensionRaw ExtensionID ByteString + deriving (Eq) + +instance Show ExtensionRaw where + show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs + +---------------------------------------------------------------- + +newtype AlertLevel = AlertLevel {fromAlertLevel :: Word8} deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern AlertLevel_Warning :: AlertLevel +pattern AlertLevel_Warning = AlertLevel 1 +pattern AlertLevel_Fatal :: AlertLevel +pattern AlertLevel_Fatal = AlertLevel 2 + +instance Show AlertLevel where + show AlertLevel_Warning = "AlertLevel_Warning" + show AlertLevel_Fatal = "AlertLevel_Fatal" + show (AlertLevel x) = "AlertLevel " ++ show x +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +newtype AlertDescription = AlertDescription {fromAlertDescription :: Word8} + deriving (Eq) + +{- FOURMOLU_DISABLE -} +pattern CloseNotify :: AlertDescription +pattern CloseNotify = AlertDescription 0 +pattern UnexpectedMessage :: AlertDescription +pattern UnexpectedMessage = AlertDescription 10 +pattern BadRecordMac :: AlertDescription +pattern BadRecordMac = AlertDescription 20 +pattern DecryptionFailed :: AlertDescription +pattern DecryptionFailed = AlertDescription 21 +pattern RecordOverflow :: AlertDescription +pattern RecordOverflow = AlertDescription 22 +pattern DecompressionFailure :: AlertDescription +pattern DecompressionFailure = AlertDescription 30 +pattern HandshakeFailure :: AlertDescription +pattern HandshakeFailure = AlertDescription 40 +pattern BadCertificate :: AlertDescription +pattern BadCertificate = AlertDescription 42 +pattern UnsupportedCertificate :: AlertDescription +pattern UnsupportedCertificate = AlertDescription 43 +pattern CertificateRevoked :: AlertDescription +pattern CertificateRevoked = AlertDescription 44 +pattern CertificateExpired :: AlertDescription +pattern CertificateExpired = AlertDescription 45 +pattern CertificateUnknown :: AlertDescription +pattern CertificateUnknown = AlertDescription 46 +pattern IllegalParameter :: AlertDescription +pattern IllegalParameter = AlertDescription 47 +pattern UnknownCa :: AlertDescription +pattern UnknownCa = AlertDescription 48 +pattern AccessDenied :: AlertDescription +pattern AccessDenied = AlertDescription 49 +pattern DecodeError :: AlertDescription +pattern DecodeError = AlertDescription 50 +pattern DecryptError :: AlertDescription +pattern DecryptError = AlertDescription 51 +pattern ExportRestriction :: AlertDescription +pattern ExportRestriction = AlertDescription 60 +pattern ProtocolVersion :: AlertDescription +pattern ProtocolVersion = AlertDescription 70 +pattern InsufficientSecurity :: AlertDescription +pattern InsufficientSecurity = AlertDescription 71 +pattern InternalError :: AlertDescription +pattern InternalError = AlertDescription 80 +pattern InappropriateFallback :: AlertDescription +pattern InappropriateFallback = AlertDescription 86 -- RFC7507 +pattern UserCanceled :: AlertDescription +pattern UserCanceled = AlertDescription 90 +pattern NoRenegotiation :: AlertDescription +pattern NoRenegotiation = AlertDescription 100 +pattern MissingExtension :: AlertDescription +pattern MissingExtension = AlertDescription 109 +pattern UnsupportedExtension :: AlertDescription +pattern UnsupportedExtension = AlertDescription 110 +pattern CertificateUnobtainable :: AlertDescription +pattern CertificateUnobtainable = AlertDescription 111 +pattern UnrecognizedName :: AlertDescription +pattern UnrecognizedName = AlertDescription 112 +pattern BadCertificateStatusResponse :: AlertDescription +pattern BadCertificateStatusResponse = AlertDescription 113 +pattern BadCertificateHashValue :: AlertDescription +pattern BadCertificateHashValue = AlertDescription 114 +pattern UnknownPskIdentity :: AlertDescription +pattern UnknownPskIdentity = AlertDescription 115 +pattern CertificateRequired :: AlertDescription +pattern CertificateRequired = AlertDescription 116 +pattern GeneralError :: AlertDescription +pattern GeneralError = AlertDescription 117 +pattern NoApplicationProtocol :: AlertDescription +pattern NoApplicationProtocol = AlertDescription 120 -- RFC7301 + +instance Show AlertDescription where + show CloseNotify = "CloseNotify" + show UnexpectedMessage = "UnexpectedMessage" + show BadRecordMac = "BadRecordMac" + show DecryptionFailed = "DecryptionFailed" + show RecordOverflow = "RecordOverflow" + show DecompressionFailure = "DecompressionFailure" + show HandshakeFailure = "HandshakeFailure" + show BadCertificate = "BadCertificate" + show UnsupportedCertificate = "UnsupportedCertificate" + show CertificateRevoked = "CertificateRevoked" + show CertificateExpired = "CertificateExpired" + show CertificateUnknown = "CertificateUnknown" + show IllegalParameter = "IllegalParameter" + show UnknownCa = "UnknownCa" + show AccessDenied = "AccessDenied" + show DecodeError = "DecodeError" + show DecryptError = "DecryptError" + show ExportRestriction = "ExportRestriction" + show ProtocolVersion = "ProtocolVersion" + show InsufficientSecurity = "InsufficientSecurity" + show InternalError = "InternalError" + show InappropriateFallback = "InappropriateFallback" + show UserCanceled = "UserCanceled" + show NoRenegotiation = "NoRenegotiation" + show MissingExtension = "MissingExtension" + show UnsupportedExtension = "UnsupportedExtension" + show CertificateUnobtainable = "CertificateUnobtainable" + show UnrecognizedName = "UnrecognizedName" + show BadCertificateStatusResponse = "BadCertificateStatusResponse" + show BadCertificateHashValue = "BadCertificateHashValue" + show UnknownPskIdentity = "UnknownPskIdentity" + show CertificateRequired = "CertificateRequired" + show GeneralError = "GeneralError" + show NoApplicationProtocol = "NoApplicationProtocol" + show (AlertDescription x) = "AlertDescription " ++ show x +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +newtype HandshakeType = HandshakeType {fromHandshakeType :: Word8} + 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 + +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 +{- 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 + , serverDHParams_y :: BigNum + } + deriving (Show, Eq) + +serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams +serverDHParamsFrom params dhPub = + ServerDHParams + (bigNumFromInteger $ dhParamsGetP params) + (bigNumFromInteger $ dhParamsGetG params) + (bigNumFromInteger $ dhUnwrapPublic dhPub) + +serverDHParamsToParams :: ServerDHParams -> DHParams +serverDHParamsToParams serverParams = + dhParams + (bigNumToInteger $ serverDHParams_p serverParams) + (bigNumToInteger $ serverDHParams_g serverParams) + +serverDHParamsToPublic :: ServerDHParams -> DHPublic +serverDHParamsToPublic serverParams = + dhPublic (bigNumToInteger $ serverDHParams_y serverParams) + +---------------------------------------------------------------- + +data ServerECDHParams = ServerECDHParams Group GroupPublic + deriving (Show, Eq) + +---------------------------------------------------------------- + +data ServerRSAParams = ServerRSAParams + { rsa_modulus :: Integer + , rsa_exponent :: Integer + } + deriving (Show, Eq) + +---------------------------------------------------------------- + +data ServerDSAParams = ServerDSAParams deriving (Show, Eq) + +---------------------------------------------------------------- + +data ServerKeyXchgAlgorithmData + = SKX_DH_Anon ServerDHParams + | SKX_DHE_DSA ServerDHParams DigitallySigned + | SKX_DHE_RSA ServerDHParams DigitallySigned + | SKX_ECDHE_RSA ServerECDHParams DigitallySigned + | SKX_ECDHE_ECDSA ServerECDHParams DigitallySigned + | SKX_RSA (Maybe ServerRSAParams) + | SKX_DH_DSA (Maybe ServerDSAParams) + | 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) + +---------------------------------------------------------------- + +data ClientKeyXchgAlgorithmData + = CKX_RSA ByteString + | CKX_DH DHPublic + | CKX_ECDH ByteString + deriving (Show, Eq) + +---------------------------------------------------------------- + +data CH = CH + { chSession :: Session + , chCiphers :: [CipherID] + , chExtensions :: [ExtensionRaw] + } + deriving (Show, Eq) + +data Handshake + = ClientHello + Version + ClientRandom + [CompressionID] + CH + | ServerHello + Version + ServerRandom + Session + CipherID + CompressionID + [ExtensionRaw] + | Certificate CertificateChain + | HelloRequest + | ServerHelloDone + | ClientKeyXchg ClientKeyXchgAlgorithmData + | ServerKeyXchg ServerKeyXchgAlgorithmData + | CertRequest + [CertificateType] + [HashAndSignatureAlgorithm] + [DistinguishedName] + | CertVerify DigitallySigned + | Finished VerifyData + | NewSessionTicket Second Ticket + deriving (Show, Eq) + +{- FOURMOLU_DISABLE -} +packetType :: Packet -> ProtocolType +packetType (Handshake _) = ProtocolType_Handshake +packetType (Alert _) = ProtocolType_Alert +packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec +packetType (AppData _) = ProtocolType_AppData + +typeOfHandshake :: Handshake -> HandshakeType +typeOfHandshake ClientHello{} = HandshakeType_ClientHello +typeOfHandshake ServerHello{} = HandshakeType_ServerHello +typeOfHandshake Certificate{} = HandshakeType_Certificate +typeOfHandshake HelloRequest = HandshakeType_HelloRequest +typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone +typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg +typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg +typeOfHandshake CertRequest{} = HandshakeType_CertRequest +typeOfHandshake CertVerify{} = HandshakeType_CertVerify +typeOfHandshake Finished{} = HandshakeType_Finished +typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket +{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -1,102 +1,58 @@ --- | --- Module : Network.TLS.Struct13 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Struct13 - ( Packet13(..) - , Handshake13(..) - , HandshakeType13(..) - , typeOfHandshake13 - , contentType - , KeyUpdate(..) - ) where +module Network.TLS.Struct13 ( + Packet13 (..), + Handshake13 (..), + typeOfHandshake13, + contentType, + KeyUpdate (..), +) where import Data.X509 (CertificateChain) +import Network.TLS.Imports import Network.TLS.Struct import Network.TLS.Types -import Network.TLS.Imports -data Packet13 = - Handshake13 [Handshake13] +data Packet13 + = Handshake13 [Handshake13] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString - deriving (Show,Eq) + deriving (Show, Eq) -data KeyUpdate = UpdateNotRequested - | UpdateRequested - deriving (Show,Eq) +data KeyUpdate + = UpdateNotRequested + | UpdateRequested + deriving (Show, Eq) type TicketNonce = ByteString -- fixme: convert Word32 to proper data type -data Handshake13 = - ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw] - | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw] - | NewSessionTicket13 Second Word32 TicketNonce SessionID [ExtensionRaw] +data Handshake13 + = ServerHello13 ServerRandom Session CipherID [ExtensionRaw] + | NewSessionTicket13 Second Word32 TicketNonce SessionIDorTicket [ExtensionRaw] | EndOfEarlyData13 | EncryptedExtensions13 [ExtensionRaw] | CertRequest13 CertReqContext [ExtensionRaw] | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]] | CertVerify13 HashAndSignatureAlgorithm Signature - | Finished13 FinishedData + | Finished13 VerifyData | KeyUpdate13 KeyUpdate - deriving (Show,Eq) - -data HandshakeType13 = - HandshakeType_ClientHello13 - | HandshakeType_ServerHello13 - | HandshakeType_EndOfEarlyData13 - | HandshakeType_NewSessionTicket13 - | HandshakeType_EncryptedExtensions13 - | HandshakeType_CertRequest13 - | HandshakeType_Certificate13 - | HandshakeType_CertVerify13 - | HandshakeType_Finished13 - | HandshakeType_KeyUpdate13 - deriving (Show,Eq) - -typeOfHandshake13 :: Handshake13 -> HandshakeType13 -typeOfHandshake13 ClientHello13{} = HandshakeType_ClientHello13 -typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello13 -typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13 -typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13 -typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions13 -typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest13 -typeOfHandshake13 Certificate13{} = HandshakeType_Certificate13 -typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify13 -typeOfHandshake13 Finished13{} = HandshakeType_Finished13 -typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate13 - -instance TypeValuable HandshakeType13 where - valOfType HandshakeType_ClientHello13 = 1 - valOfType HandshakeType_ServerHello13 = 2 - valOfType HandshakeType_NewSessionTicket13 = 4 - valOfType HandshakeType_EndOfEarlyData13 = 5 - valOfType HandshakeType_EncryptedExtensions13 = 8 - valOfType HandshakeType_CertRequest13 = 13 - valOfType HandshakeType_Certificate13 = 11 - valOfType HandshakeType_CertVerify13 = 15 - valOfType HandshakeType_Finished13 = 20 - valOfType HandshakeType_KeyUpdate13 = 24 + deriving (Show, Eq) - valToType 1 = Just HandshakeType_ClientHello13 - valToType 2 = Just HandshakeType_ServerHello13 - valToType 4 = Just HandshakeType_NewSessionTicket13 - valToType 5 = Just HandshakeType_EndOfEarlyData13 - valToType 8 = Just HandshakeType_EncryptedExtensions13 - valToType 13 = Just HandshakeType_CertRequest13 - valToType 11 = Just HandshakeType_Certificate13 - valToType 15 = Just HandshakeType_CertVerify13 - valToType 20 = Just HandshakeType_Finished13 - valToType 24 = Just HandshakeType_KeyUpdate13 - valToType _ = Nothing +{- 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 contentType :: Packet13 -> ProtocolType contentType ChangeCipherSpec13 = ProtocolType_ChangeCipherSpec -contentType (Handshake13 _) = ProtocolType_Handshake -contentType (Alert13 _) = ProtocolType_Alert -contentType (AppData13 _) = ProtocolType_AppData +contentType Handshake13{} = ProtocolType_Handshake +contentType Alert13{} = ProtocolType_Alert +contentType AppData13{} = ProtocolType_AppData +{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -1,90 +1,124 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} --- | --- Module : Network.TLS.Types --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- -module Network.TLS.Types - ( Version(..) - , SessionID - , SessionData(..) - , SessionFlag(..) - , CertReqContext - , TLS13TicketInfo(..) - , CipherID - , CompressionID - , Role(..) - , invertRole - , Direction(..) - , HostName - , Second - , Millisecond - , EarlySecret - , HandshakeSecret - , ApplicationSecret - , ResumptionSecret - , BaseSecret(..) - , AnyTrafficSecret(..) - , ClientTrafficSecret(..) - , ServerTrafficSecret(..) - , TrafficSecrets - , SecretTriple(..) - , SecretPair(..) - , MasterSecret(..) - ) where +{-# LANGUAGE PatternSynonyms #-} -#ifdef INCLUDE_NETWORK -import Network.Socket (HostName) -#endif +module Network.TLS.Types ( + Version (Version, SSL2, SSL3, TLS10, TLS11, TLS12, TLS13), + SessionID, + SessionIDorTicket, + Ticket, + isTicket, + toSessionID, + SessionData (..), + SessionFlag (..), + CertReqContext, + TLS13TicketInfo (..), + CipherID, + CompressionID, + Role (..), + invertRole, + Direction (..), + HostName, + Second, + Millisecond, + EarlySecret, + HandshakeSecret, + ApplicationSecret, + ResumptionSecret, + BaseSecret (..), + AnyTrafficSecret (..), + ClientTrafficSecret (..), + ServerTrafficSecret (..), + TrafficSecrets, + SecretTriple (..), + SecretPair (..), + MainSecret (..), +) 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.Crypto.Types (Group) -#ifndef INCLUDE_NETWORK -type HostName = String -#endif -type Second = Word32 +type Second = Word32 type Millisecond = Word64 -- | Versions known to TLS --- --- SSL2 is just defined, but this version is and will not be supported. -data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13 deriving (Show, Eq, Ord, Bounded) +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 + { sessionVersion :: Version + , sessionCipher :: CipherID , sessionCompression :: CompressionID - , sessionClientSNI :: Maybe HostName - , sessionSecret :: ByteString - , sessionGroup :: Maybe Group - , sessionTicketInfo :: Maybe TLS13TicketInfo - , sessionALPN :: Maybe ByteString + , sessionClientSNI :: Maybe HostName + , sessionSecret :: ByteString + , sessionGroup :: Maybe Group + , sessionTicketInfo :: Maybe TLS13TicketInfo + , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int - , sessionFlags :: [SessionFlag] - } deriving (Show,Eq) + , sessionFlags :: [SessionFlag] + } -- sessionFromTicket :: Bool + deriving (Show, Eq, Generic) -- | Some session flags data SessionFlag - = SessionEMS -- ^ Session created with Extended Master Secret - deriving (Show,Eq,Enum) + = -- | 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 + { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds + , ageAdd :: Second -- NewSessionTicket.ticket_age_add , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime , estimatedRTT :: Maybe Millisecond - } deriving (Show, Eq) + } + deriving (Show, Eq, Generic) -- | Cipher identification type CipherID = Word16 @@ -94,11 +128,11 @@ -- | Role data Role = ClientRole | ServerRole - deriving (Show,Eq) + deriving (Show, Eq) -- | Direction data Direction = Tx | Rx - deriving (Show,Eq) + deriving (Show, Eq) invertRole :: Role -> Role invertRole ClientRole = ServerRole @@ -115,30 +149,38 @@ data ResumptionSecret -newtype BaseSecret a = BaseSecret ByteString deriving Show -newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving Show +newtype BaseSecret a = BaseSecret ByteString deriving (Show) +newtype AnyTrafficSecret a = AnyTrafficSecret ByteString deriving (Show) -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. -newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving Show +newtype ClientTrafficSecret a = ClientTrafficSecret ByteString deriving (Show) -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule. -newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving Show +newtype ServerTrafficSecret a = ServerTrafficSecret ByteString deriving (Show) data SecretTriple a = SecretTriple - { triBase :: BaseSecret a + { triBase :: BaseSecret a , triClient :: ClientTrafficSecret a , triServer :: ServerTrafficSecret a } + deriving (Show) data SecretPair a = SecretPair - { pairBase :: BaseSecret a + { pairBase :: BaseSecret a , pairClient :: ClientTrafficSecret a } -- | Hold both client and server traffic secrets at the same step. type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) --- Master secret for TLS 1.2 or earlier. -newtype MasterSecret = MasterSecret ByteString deriving Show +-- Main secret for TLS 1.2 or earlier. +newtype MainSecret = MainSecret ByteString deriving (Show) + +---------------------------------------------------------------- + +instance Serialise Version +instance Serialise TLS13TicketInfo +instance Serialise SessionFlag +instance Serialise SessionData diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -1,77 +1,71 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Network.TLS.Util - ( sub - , takelast - , partition3 - , partition6 - , fromJust - , (&&!) - , bytesEq - , fmapEither - , catchException - , forEitherM - , mapChunks_ - , getChunks - , Saved - , saveMVar - , restoreMVar - ) where -import qualified Data.ByteArray as BA +module Network.TLS.Util ( + sub, + takelast, + partition3, + partition6, + (&&!), + fmapEither, + catchException, + forEitherM, + mapChunks_, + getChunks, + Saved, + saveMVar, + restoreMVar, +) where + import qualified Data.ByteString as B import Network.TLS.Imports -import Control.Exception (SomeException) import Control.Concurrent.Async import Control.Concurrent.MVar +import Control.Exception (SomeException) sub :: ByteString -> Int -> Int -> Maybe ByteString sub b offset len | B.length b < offset + len = Nothing - | otherwise = Just $ B.take len $ snd $ B.splitAt offset b + | otherwise = Just $ B.take len $ snd $ B.splitAt offset b takelast :: Int -> ByteString -> Maybe ByteString takelast i b | B.length b >= i = sub b (B.length b - i) i - | otherwise = Nothing + | otherwise = Nothing -partition3 :: ByteString -> (Int,Int,Int) -> Maybe (ByteString, ByteString, ByteString) -partition3 bytes (d1,d2,d3) - | any (< 0) l = Nothing +partition3 + :: ByteString -> (Int, Int, Int) -> Maybe (ByteString, ByteString, ByteString) +partition3 bytes (d1, d2, d3) + | any (< 0) l = Nothing | sum l /= B.length bytes = Nothing - | otherwise = Just (p1,p2,p3) - where l = [d1,d2,d3] - (p1, r1) = B.splitAt d1 bytes - (p2, r2) = B.splitAt d2 r1 - (p3, _) = B.splitAt d3 r2 - -partition6 :: ByteString -> (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) - 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 + | otherwise = Just (p1, p2, p3) + where + l = [d1, d2, d3] + (p1, r1) = B.splitAt d1 bytes + (p2, r2) = B.splitAt d2 r1 + (p3, _) = B.splitAt d3 r2 -fromJust :: String -> Maybe a -> a -fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck -fromJust _ (Just x) = x +partition6 + :: ByteString + -> (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) + 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 -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool -True &&! True = True -True &&! False = False -False &&! True = False +True &&! True = True +True &&! False = False +False &&! True = False False &&! False = False --- | verify that 2 bytestrings are equals. --- it's a non lazy version, that will compare every bytes. --- arguments with different length will bail out early -bytesEq :: ByteString -> ByteString -> Bool -bytesEq = BA.constEq - fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f @@ -79,24 +73,29 @@ catchException action handler = withAsync action waitCatch >>= either handler return forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b]) -forEitherM [] _ = return (pure []) -forEitherM (x:xs) f = f x >>= doTail +forEitherM [] _ = return (pure []) +forEitherM (x : xs) f = f x >>= doTail where doTail (Right b) = fmap (b :) <$> forEitherM xs f - doTail (Left e) = return (Left e) + doTail (Left e) = return (Left e) -mapChunks_ :: Monad m - => Maybe Int -> (B.ByteString -> m a) -> B.ByteString -> m () +mapChunks_ + :: Monad m + => Maybe Int + -> (B.ByteString -> m a) + -> B.ByteString + -> m () mapChunks_ len f = mapM_ f . getChunks len getChunks :: Maybe Int -> B.ByteString -> [B.ByteString] -getChunks Nothing = (: []) +getChunks Nothing = (: []) getChunks (Just len) = go where - go bs | B.length bs > len = - let (chunk, remain) = B.splitAt len bs - in chunk : go remain - | otherwise = [bs] + go bs + | B.length bs > len = + let (chunk, remain) = B.splitAt len bs + in chunk : go remain + | otherwise = [bs] -- | An opaque newtype wrapper to prevent from poking inside content that has -- been saved. diff --git a/Network/TLS/Util/ASN1.hs b/Network/TLS/Util/ASN1.hs --- a/Network/TLS/Util/ASN1.hs +++ b/Network/TLS/Util/ASN1.hs @@ -1,37 +1,31 @@ --- | --- Module : Network.TLS.Util.ASN1 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- ASN1 utils for TLS --- -module Network.TLS.Util.ASN1 - ( decodeASN1Object - , encodeASN1Object - ) where +-- | ASN1 utils for TLS +module Network.TLS.Util.ASN1 ( + decodeASN1Object, + encodeASN1Object, +) where -import Network.TLS.Imports -import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) +import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1', encodeASN1') -import Data.ASN1.BinaryEncoding (DER(..)) +import Data.ASN1.Types (ASN1Object, fromASN1, toASN1) +import Network.TLS.Imports -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object. -decodeASN1Object :: ASN1Object a - => String - -> ByteString - -> Either String a +decodeASN1Object + :: ASN1Object a + => String + -> ByteString + -> Either String a decodeASN1Object name bs = case decodeASN1' DER bs of - Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e) + Left e -> Left (name ++ ": cannot decode ASN1: " ++ show e) Right asn1 -> case fromASN1 asn1 of - Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e) - Right (d,_) -> Right d + Left e -> Left (name ++ ": cannot parse ASN1: " ++ show e) + Right (d, _) -> Right d -- | Encode an ASN.1 Object to the DER serialized bytestring -encodeASN1Object :: ASN1Object a - => a - -> ByteString +encodeASN1Object + :: ASN1Object a + => a + -> ByteString encodeASN1Object obj = encodeASN1' DER $ toASN1 obj [] diff --git a/Network/TLS/Util/Serialization.hs b/Network/TLS/Util/Serialization.hs --- a/Network/TLS/Util/Serialization.hs +++ b/Network/TLS/Util/Serialization.hs @@ -1,7 +1,7 @@ -module Network.TLS.Util.Serialization - ( os2ip - , i2osp - , i2ospOf_ - ) where +module Network.TLS.Util.Serialization ( + os2ip, + i2osp, + i2ospOf_, +) where -import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_) +import Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -1,87 +1,82 @@ --- | --- Module : Network.TLS.Wire --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- the Wire module is a specialized marshalling/unmarshalling package related to the TLS protocol. --- all multibytes values are written as big endian. --- -module Network.TLS.Wire - ( Get - , GetResult(..) - , GetContinuation - , runGet - , runGetErr - , runGetMaybe - , tryGet - , remaining - , getWord8 - , getWords8 - , getWord16 - , getWords16 - , getWord24 - , getWord32 - , getWord64 - , getBytes - , getOpaque8 - , getOpaque16 - , getOpaque24 - , getInteger16 - , getBigNum16 - , getList - , processBytes - , isEmpty - , Put - , runPut - , putWord8 - , putWords8 - , putWord16 - , putWords16 - , putWord24 - , putWord32 - , putWord64 - , putBytes - , putOpaque8 - , putOpaque16 - , putOpaque24 - , putInteger16 - , putBigNum16 - , encodeWord16 - , encodeWord32 - , encodeWord64 - ) where +-- | The Wire module is a specialized marshalling/unmarshalling +-- package related to the TLS protocol. All multibytes values are +-- written as big endian. +module Network.TLS.Wire ( + Get, + GetResult (..), + GetContinuation, + runGet, + runGetErr, + runGetMaybe, + tryGet, + remaining, + getWord8, + getWords8, + getWord16, + getWords16, + getWord24, + getWord32, + getWord64, + getBytes, + getOpaque8, + getOpaque16, + getOpaque24, + getInteger16, + getBigNum16, + getList, + processBytes, + isEmpty, + Put, + runPut, + putWord8, + putWords8, + putWord16, + putWords16, + putWord24, + putWord32, + putWord64, + putBytes, + putOpaque8, + putOpaque16, + putOpaque24, + putInteger16, + putBigNum16, + encodeWord16, + encodeWord32, + encodeWord64, +) where +import qualified Data.ByteString as B import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put -import qualified Data.ByteString as B -import Network.TLS.Struct import Network.TLS.Imports +import Network.TLS.Struct import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a -data GetResult a = - GotError TLSError +data GetResult a + = GotError TLSError | GotPartial (GetContinuation a) | GotSuccess a | GotSuccessRemaining a ByteString runGet :: String -> Get a -> ByteString -> GetResult a runGet lbl f = toGetResult <$> G.runGetPartial (label lbl f) - where toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err) - toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont) - toGetResult (G.Done r bsLeft) - | B.null bsLeft = GotSuccess r - | otherwise = GotSuccessRemaining r bsLeft + where + toGetResult (G.Fail err _) = GotError (Error_Packet_Parsing err) + toGetResult (G.Partial cont) = GotPartial (toGetResult <$> cont) + toGetResult (G.Done r bsLeft) + | B.null bsLeft = GotSuccess r + | otherwise = GotSuccessRemaining r bsLeft runGetErr :: String -> Get a -> ByteString -> Either TLSError a runGetErr lbl getter b = toSimple $ runGet lbl getter b - where toSimple (GotError err) = Left err - toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet")) - toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) - toSimple (GotSuccess r) = Right r + where + toSimple (GotError err) = Left err + toSimple (GotPartial _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: partial packet")) + toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) + toSimple (GotSuccess r) = Right r runGetMaybe :: Get a -> ByteString -> Maybe a runGetMaybe f = either (const Nothing) Just . G.runGet f @@ -128,10 +123,13 @@ getList :: Int -> Get (Int, a) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) - where getElements len - | len < 0 = error "list consumed too much data. should never happen with isolate." - | len == 0 = return [] - | otherwise = getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) + where + getElements len + | len < 0 = + error "list consumed too much data. should never happen with isolate." + | len == 0 = return [] + | otherwise = + getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f @@ -160,7 +158,7 @@ let a = fromIntegral ((i `shiftR` 16) .&. 0xff) let b = fromIntegral ((i `shiftR` 8) .&. 0xff) let c = fromIntegral (i .&. 0xff) - mapM_ putWord8 [a,b,c] + mapM_ putWord8 [a, b, c] putBytes :: ByteString -> Put putBytes = putByteString diff --git a/Network/TLS/X509.hs b/Network/TLS/X509.hs --- a/Network/TLS/X509.hs +++ b/Network/TLS/X509.hs @@ -1,66 +1,60 @@ --- | --- Module : Network.TLS.X509 --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unknown --- --- X509 helpers --- -module Network.TLS.X509 - ( CertificateChain(..) - , Certificate(..) - , SignedCertificate - , getCertificate - , isNullCertificateChain - , getCertificateChainLeaf - , CertificateRejectReason(..) - , CertificateUsage(..) - , CertificateStore - , ValidationCache - , exceptionValidationCache - , validateDefault - , FailedReason - , ServiceID - , wrapCertificateChecks - , pubkeyType - ) where +-- | X509 helpers +module Network.TLS.X509 ( + CertificateChain (..), + Certificate (..), + SignedCertificate, + getCertificate, + isNullCertificateChain, + getCertificateChainLeaf, + CertificateRejectReason (..), + CertificateUsage (..), + CertificateStore, + ValidationCache, + exceptionValidationCache, + validateDefault, + FailedReason, + ServiceID, + wrapCertificateChecks, + pubkeyType, +) where import Data.X509 -import Data.X509.Validation import Data.X509.CertificateStore +import Data.X509.Validation isNullCertificateChain :: CertificateChain -> Bool isNullCertificateChain (CertificateChain l) = null l getCertificateChainLeaf :: CertificateChain -> SignedExact Certificate -getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain" -getCertificateChainLeaf (CertificateChain (x:_)) = x +getCertificateChainLeaf (CertificateChain []) = error "empty certificate chain" +getCertificateChainLeaf (CertificateChain (x : _)) = x -- | Certificate and Chain rejection reason -data CertificateRejectReason = - CertificateRejectExpired - | CertificateRejectRevoked - | CertificateRejectUnknownCA - | CertificateRejectAbsent - | CertificateRejectOther String - deriving (Show,Eq) +data CertificateRejectReason + = CertificateRejectExpired + | CertificateRejectRevoked + | CertificateRejectUnknownCA + | CertificateRejectAbsent + | CertificateRejectOther String + deriving (Show, Eq) -- | Certificate Usage callback possible returns values. -data CertificateUsage = - CertificateUsageAccept -- ^ usage of certificate accepted - | CertificateUsageReject CertificateRejectReason -- ^ usage of certificate rejected - deriving (Show,Eq) +data CertificateUsage + = -- | usage of certificate accepted + CertificateUsageAccept + | -- | usage of certificate rejected + CertificateUsageReject CertificateRejectReason + deriving (Show, Eq) wrapCertificateChecks :: [FailedReason] -> CertificateUsage wrapCertificateChecks [] = CertificateUsageAccept wrapCertificateChecks l - | Expired `elem` l = CertificateUsageReject CertificateRejectExpired - | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired - | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA - | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA - | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent - | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) + | Expired `elem` l = CertificateUsageReject CertificateRejectExpired + | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired + | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA + | SelfSigned `elem` l = CertificateUsageReject CertificateRejectUnknownCA + | EmptyChain `elem` l = CertificateUsageReject CertificateRejectAbsent + | otherwise = CertificateUsageReject $ CertificateRejectOther (show l) pubkeyType :: PubKey -> String pubkeyType = show . pubkeyToAlg diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/Tests/Certificate.hs b/Tests/Certificate.hs deleted file mode 100644 --- a/Tests/Certificate.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Certificate - ( arbitraryX509 - , arbitraryX509WithKey - , arbitraryX509WithKeyAndUsage - , arbitraryDN - , arbitraryKeyUsage - , simpleCertificate - , simpleX509 - , toPubKeyEC - , toPrivKeyEC - ) where - -import Control.Applicative -import Test.Tasty.QuickCheck -import Data.ASN1.OID -import Data.X509 -import Data.Hourglass -import Crypto.Number.Serialize (i2ospOf_) -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Types as ECC -import qualified Data.ByteString as B - -import PubKey - -arbitraryDN :: Gen DistinguishedName -arbitraryDN = return $ DistinguishedName [] - -instance Arbitrary Date where - arbitrary = do - y <- choose (1971, 2035) - m <- elements [ January .. December] - d <- choose (1, 30) - return $ normalizeDate $ Date y m d - -normalizeDate :: Date -> Date -normalizeDate d = timeConvert (timeConvert d :: Elapsed) - -instance Arbitrary TimeOfDay where - arbitrary = do - h <- choose (0, 23) - mi <- choose (0, 59) - se <- choose (0, 59) - nsec <- return 0 - return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec - -instance Arbitrary DateTime where - arbitrary = DateTime <$> arbitrary <*> arbitrary - -maxSerial :: Integer -maxSerial = 16777216 - -arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate -arbitraryCertificate usageFlags pubKey = do - serial <- choose (0,maxSerial) - subjectdn <- arbitraryDN - validity <- (,) <$> arbitrary <*> arbitrary - let sigalg = getSignatureALG pubKey - return $ Certificate - { certVersion = 3 - , certSerial = serial - , certSignatureAlg = sigalg - , certIssuerDN = issuerdn - , certSubjectDN = subjectdn - , certValidity = validity - , certPubKey = pubKey - , certExtensions = Extensions $ Just - [ extensionEncode True $ ExtKeyUsage usageFlags - ] - } - where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] - -simpleCertificate :: PubKey -> Certificate -simpleCertificate pubKey = - Certificate - { certVersion = 3 - , certSerial = 0 - , certSignatureAlg = getSignatureALG pubKey - , certIssuerDN = simpleDN - , certSubjectDN = simpleDN - , certValidity = (time1, time2) - , certPubKey = pubKey - , certExtensions = Extensions $ Just - [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment] - ] - } - where time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) - time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) - simpleDN = DistinguishedName [] - -simpleX509 :: PubKey -> SignedCertificate -simpleX509 pubKey = - let cert = simpleCertificate pubKey - sig = replicate 40 1 - sigalg = getSignatureALG pubKey - (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert - in signedExact - -arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate -arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage - -arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate -arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do - cert <- arbitraryCertificate usageFlags pubKey - sig <- resize 40 $ listOf1 arbitrary - let sigalg = getSignatureALG pubKey - let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert - return signedExact - -arbitraryX509 :: Gen SignedCertificate -arbitraryX509 = do - let (pubKey, privKey) = getGlobalRSAPair - arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) - -arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] -arbitraryKeyUsage = sublistOf knownKeyUsage - -knownKeyUsage :: [ExtKeyUsageFlag] -knownKeyUsage = [ KeyUsage_digitalSignature - , KeyUsage_keyEncipherment - , KeyUsage_keyAgreement - ] - -getSignatureALG :: PubKey -> SignatureALG -getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA -getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA -getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC -getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 -getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey - -toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey -toPubKeyEC curveName key = - let ECC.Point x y = ECDSA.public_q key - pub = SerializedPoint bs - bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) - bits = ECC.curveSizeBits (ECC.getCurveByName curveName) - bytes = (bits + 7) `div` 8 - in PubKeyEC (PubKeyEC_Named curveName pub) - -toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey -toPrivKeyEC curveName key = - let priv = ECDSA.private_d key - in PrivKeyEC (PrivKeyEC_Named curveName priv) diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs deleted file mode 100644 --- a/Tests/Ciphers.hs +++ /dev/null @@ -1,50 +0,0 @@ --- Disable this warning so we can still test deprecated functionality. -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Ciphers - ( propertyBulkFunctional - ) where - -import Control.Applicative ((<$>), (<*>)) - -import Test.Tasty.QuickCheck - -import qualified Data.ByteString as B -import Network.TLS.Cipher -import Network.TLS.Extra.Cipher - -arbitraryKey :: Bulk -> Gen B.ByteString -arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) - -arbitraryIV :: Bulk -> Gen B.ByteString -arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) - -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 - deriving (Show,Eq) - -instance Arbitrary BulkTest where - arbitrary = do - bulk <- cipherBulk `fmap` elements ciphersuite_all - BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk <*> arbitraryText bulk - -propertyBulkFunctional :: BulkTest -> Bool -propertyBulkFunctional (BulkTest bulk key iv t additional) = - let enc = bulkInit bulk BulkEncrypt key - dec = bulkInit bulk BulkDecrypt key - in case (enc, dec) of - (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF - (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF - (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF - _ -> True - where - block e d = - let (etxt, e_iv) = e iv t - (dtxt, d_iv) = d iv etxt - in dtxt == t && d_iv == e_iv - stream e d = (fst . d . fst . e) t == t - aead e d = - let (encrypted, at) = e iv t additional - (decrypted, at2) = d iv encrypted additional - in decrypted == t && at == at2 diff --git a/Tests/Connection.hs b/Tests/Connection.hs deleted file mode 100644 --- a/Tests/Connection.hs +++ /dev/null @@ -1,426 +0,0 @@ --- Disable this warning so we can still test deprecated functionality. -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Connection - ( newPairContext - , arbitraryCiphers - , arbitraryVersions - , arbitraryHashSignatures - , arbitraryGroups - , arbitraryKeyUsage - , arbitraryPairParams - , arbitraryPairParams13 - , arbitraryPairParamsWithVersionsAndCiphers - , arbitraryClientCredential - , arbitraryCredentialsOfEachCurve - , arbitraryRSACredentialWithUsage - , dhParamsGroup - , getConnectVersion - , isVersionEnabled - , isCustomDHParams - , isLeafRSA - , isCredentialDSA - , arbitraryEMSMode - , setEMSMode - , readClientSessionRef - , twoSessionRefs - , twoSessionManagers - , setPairParamsSessionManagers - , setPairParamsSessionResuming - , withDataPipe - , initiateDataPipe - , byeBye - ) where - -import Test.Tasty.QuickCheck -import Certificate -import PubKey -import PipeChan -import Network.TLS as TLS -import Network.TLS.Extra -import Data.X509 -import Data.Default.Class -import Data.IORef -import Control.Applicative -import Control.Concurrent.Async -import Control.Concurrent.Chan -import Control.Concurrent -import qualified Control.Exception as E -import Control.Monad (unless, when) -import Data.List (intersect, isInfixOf) - -import qualified Data.ByteString as B - -debug :: Bool -debug = False - -knownCiphers :: [Cipher] -knownCiphers = ciphersuite_all ++ ciphersuite_weak - where - ciphersuite_weak = [ - cipher_DHE_DSS_RC4_SHA1 - , cipher_RC4_128_MD5 - , cipher_null_MD5 - , cipher_null_SHA1 - ] - -arbitraryCiphers :: Gen [Cipher] -arbitraryCiphers = listOf1 $ elements knownCiphers - -knownVersions :: [Version] -knownVersions = [TLS13,TLS12,TLS11,TLS10] - -arbitraryVersions :: Gen [Version] -arbitraryVersions = sublistOf knownVersions - --- for performance reason ecdsa_secp521r1_sha512 is not tested -knownHashSignatures :: [HashAndSignatureAlgorithm] -knownHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512) - ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA384) - ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA256) - ,(TLS.HashIntrinsic, SignatureEd25519) - ,(TLS.HashIntrinsic, SignatureEd448) - ,(TLS.HashSHA512, SignatureRSA) - ,(TLS.HashSHA384, SignatureRSA) - ,(TLS.HashSHA384, SignatureECDSA) - ,(TLS.HashSHA256, SignatureRSA) - ,(TLS.HashSHA256, SignatureECDSA) - ,(TLS.HashSHA1, SignatureRSA) - ,(TLS.HashSHA1, SignatureDSS) - ] - -knownHashSignatures13 :: [HashAndSignatureAlgorithm] -knownHashSignatures13 = filter compat knownHashSignatures - where - compat (h,s) = h /= TLS.HashSHA1 && s /= SignatureDSS && s /= SignatureRSA - -arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm] -arbitraryHashSignatures v = sublistOf l - where l = if v < TLS13 then knownHashSignatures else knownHashSignatures13 - --- for performance reason P521, FFDHE6144, FFDHE8192 are not tested -knownGroups, knownECGroups, knownFFGroups :: [Group] -knownECGroups = [P256,P384,X25519,X448] -knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096] -knownGroups = knownECGroups ++ knownFFGroups - -defaultECGroup :: Group -defaultECGroup = P256 -- same as defaultECCurve - -otherKnownECGroups :: [Group] -otherKnownECGroups = filter (/= defaultECGroup) knownECGroups - -arbitraryGroups :: Gen [Group] -arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups - -isCredentialDSA :: (CertificateChain, PrivKey) -> Bool -isCredentialDSA (_, PrivKeyDSA _) = True -isCredentialDSA _ = False - -arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle - -arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachType' = do - let (pubKey, privKey) = getGlobalRSAPair - curveName = defaultECCurve - (dsaPub, dsaPriv) <- arbitraryDSAPair - (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName - (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair - (ed448Pub, ed448Priv) <- arbitraryEd448Pair - mapM (\(pub, priv) -> do - cert <- arbitraryX509WithKey (pub, priv) - return (CertificateChain [cert], priv) - ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey) - , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) - , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) - , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) - , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) - ] - -arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle - -arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachCurve' = do - ecdsaPairs <- - mapM (\curveName -> do - (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName - return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) - ) knownECCurves - (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair - (ed448Pub, ed448Priv) <- arbitraryEd448Pair - mapM (\(pub, priv) -> do - cert <- arbitraryX509WithKey (pub, priv) - return (CertificateChain [cert], priv) - ) $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) - , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) - ] ++ ecdsaPairs - -dhParamsGroup :: DHParams -> Maybe Group -dhParamsGroup params - | params == ffdhe2048 = Just FFDHE2048 - | params == ffdhe3072 = Just FFDHE3072 - | otherwise = Nothing - -isCustomDHParams :: DHParams -> Bool -isCustomDHParams params = params == dhParams512 - -leafPublicKey :: CertificateChain -> Maybe PubKey -leafPublicKey (CertificateChain []) = Nothing -leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ getCertificate leaf) - -isLeafRSA :: Maybe CertificateChain -> Bool -isLeafRSA chain = case chain >>= leafPublicKey of - Just (PubKeyRSA _) -> True - _ -> False - -arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) -arbitraryCipherPair connectVersion = do - serverCiphers <- arbitraryCiphers `suchThat` - (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) - clientCiphers <- arbitraryCiphers `suchThat` - (\cs -> or [x `elem` serverCiphers && - cipherAllowedForVersion connectVersion x | x <- cs]) - return (clientCiphers, serverCiphers) - -arbitraryPairParams :: Gen (ClientParams, ServerParams) -arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt - --- Pair of groups so that at least the default EC group P256 and one FF group --- are in common. This makes DHE and ECDHE ciphers always compatible with --- extension "Supported Elliptic Curves" / "Supported Groups". -arbitraryGroupPair :: Gen ([Group], [Group]) -arbitraryGroupPair = do - (serverECGroups, clientECGroups) <- arbitraryGroupPairWith defaultECGroup otherKnownECGroups - (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups - serverGroups <- shuffle (serverECGroups ++ serverFFGroups) - clientGroups <- shuffle (clientECGroups ++ clientFFGroups) - return (clientGroups, serverGroups) - where - arbitraryGroupPairFrom list = elements list >>= \e -> - arbitraryGroupPairWith e (filter (/= e) list) - arbitraryGroupPairWith e es = do - s <- sublistOf es - c <- sublistOf es - return (e : s, e : c) - -arbitraryPairParams13 :: Gen (ClientParams, ServerParams) -arbitraryPairParams13 = arbitraryPairParamsAt TLS13 - -arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) -arbitraryPairParamsAt connectVersion = do - (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion - -- Select version lists containing connectVersion, as well as some other - -- 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 ]] - allowedVersionsFiltered = filter (<= connectVersion) allowedVersions - -- Server or client is allowed to have versions > connectVersion, but not - -- both simultaneously. - filterSrv <- arbitrary - let (clientAllowedVersions, serverAllowedVersions) - | filterSrv = (allowedVersions, allowedVersionsFiltered) - | otherwise = (allowedVersionsFiltered, allowedVersions) - -- Generate version lists containing less than 127 elements, otherwise the - -- "supported_versions" extension cannot be correctly serialized - clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions - serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions - arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) - where - listWithOthers :: a -> Int -> [a] -> Gen [a] - listWithOthers fixedElement maxOthers others - | maxOthers < 1 = return [fixedElement] - | otherwise = sized $ \n -> do - num <- choose (0, min n maxOthers) - pos <- choose (0, num) - prefix <- vectorOf pos $ elements others - suffix <- vectorOf (num - pos) $ elements others - return $ prefix ++ (fixedElement : suffix) - -getConnectVersion :: (ClientParams, ServerParams) -> Version -getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) - where - sver = supportedVersions (serverSupported sparams) - cver = supportedVersions (clientSupported cparams) - -isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool -isVersionEnabled ver (cparams, sparams) = - (ver `elem` supportedVersions (serverSupported sparams)) && - (ver `elem` supportedVersions (clientSupported cparams)) - -arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -arbitraryHashSignaturePair = do - serverHashSignatures <- shuffle knownHashSignatures - clientHashSignatures <- shuffle knownHashSignatures - return (clientHashSignatures, serverHashSignatures) - -arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) - -> ([Cipher], [Cipher]) - -> Gen (ClientParams, ServerParams) -arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do - secNeg <- arbitrary - dhparams <- elements [dhParams512,ffdhe2048,ffdhe3072] - - creds <- arbitraryCredentialsOfEachType - (clientGroups, serverGroups) <- arbitraryGroupPair - (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair - let serverState = def - { serverSupported = def { supportedCiphers = serverCiphers - , supportedVersions = serverVersions - , supportedSecureRenegotiation = secNeg - , supportedGroups = serverGroups - , supportedHashSignatures = serverHashSignatures - } - , serverDHEParams = Just dhparams - , serverShared = def { sharedCredentials = Credentials creds } - } - let clientState = (defaultParamsClient "" B.empty) - { clientSupported = def { supportedCiphers = clientCiphers - , supportedVersions = clientVersions - , supportedSecureRenegotiation = secNeg - , supportedGroups = clientGroups - , supportedHashSignatures = clientHashSignatures - } - , clientShared = def { sharedValidationCache = ValidationCache - { cacheAdd = \_ _ _ -> return () - , cacheQuery = \_ _ _ -> return ValidationCachePass - } - } - } - return (clientState, serverState) - -arbitraryClientCredential :: Version -> Gen Credential -arbitraryClientCredential SSL3 = do - -- for SSL3 there is no EC but only RSA/DSA - creds <- arbitraryCredentialsOfEachType' - elements (take 2 creds) -- RSA and DSA, but not ECDSA, Ed25519 and Ed448 -arbitraryClientCredential v | v < TLS12 = do - -- for TLS10 and TLS11 there is no EdDSA but only RSA/DSA/ECDSA - creds <- arbitraryCredentialsOfEachType' - elements (take 3 creds) -- RSA, DSA and ECDSA, but not EdDSA -arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements - -arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) -arbitraryRSACredentialWithUsage usageFlags = do - let (pubKey, privKey) = getGlobalRSAPair - cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) - return (CertificateChain [cert], PrivKeyRSA privKey) - -arbitraryEMSMode :: Gen (EMSMode, EMSMode) -arbitraryEMSMode = (,) <$> gen <*> gen - where gen = elements [ NoEMS, AllowEMS, RequireEMS ] - -setEMSMode :: (EMSMode, EMSMode) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) -setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') - where - clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedExtendedMasterSec = cems } - } - serverParam' = serverParam { serverSupported = (serverSupported serverParam) - { supportedExtendedMasterSec = sems } - } - -readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient -readClientSessionRef refs = readIORef (fst refs) - -twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server)) -twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing - --- | simple session manager to store one session id and session data for a single thread. --- a Real concurrent session manager would use an MVar and have multiples items. -oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager -oneSessionManager ref = SessionManager - { sessionResume = \myId -> readIORef ref >>= maybeResume False myId - , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId - , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) - , sessionInvalidate = \_ -> return () - } - where - maybeResume onlyOnce myId (Just (sid, sdata)) - | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata) - maybeResume _ _ _ = return Nothing - -twoSessionManagers :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) -> (SessionManager, SessionManager) -twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) - -setPairParamsSessionManagers :: (SessionManager, SessionManager) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) -setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc,ns) - where nc = clientState { clientShared = updateSessionManager clientManager $ clientShared clientState } - ns = serverState { serverShared = updateSessionManager serverManager $ serverShared serverState } - updateSessionManager manager shared = shared { sharedSessionManager = manager } - -setPairParamsSessionResuming :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) -setPairParamsSessionResuming sessionStuff (clientState, serverState) = - ( clientState { clientWantSessionResume = Just sessionStuff } - , serverState) - -newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) -newPairContext pipe (cParams, sParams) = do - let noFlush = return () - let noClose = return () - - let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) - let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) - cCtx' <- contextNew cBackend cParams - sCtx' <- contextNew sBackend sParams - - contextHookSetLogging cCtx' (logging "client: ") - contextHookSetLogging sCtx' (logging "server: ") - - return (cCtx', sCtx') - where - logging pre = - if debug - then def { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) - , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } - else def - -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 - pipe <- newPipe - _ <- runPipe pipe - startQueue <- newChan - resultQueue <- newChan - - (cCtx, sCtx) <- newPairContext pipe 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 - -initiateDataPipe :: (ClientParams, ServerParams) -> (Context -> IO a1) -> (Context -> IO a) -> IO (Either E.SomeException a, Either E.SomeException a1) -initiateDataPipe params tlsServer tlsClient = do - -- initial setup - pipe <- newPipe - _ <- runPipe pipe - - (cCtx, sCtx) <- newPairContext pipe params - - async (tlsServer sCtx) >>= \sAsync -> - async (tlsClient cCtx) >>= \cAsync -> do - sRes <- waitCatch sAsync - cRes <- waitCatch cAsync - return (cRes, sRes) - --- 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" diff --git a/Tests/Marshalling.hs b/Tests/Marshalling.hs deleted file mode 100644 --- a/Tests/Marshalling.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Marshalling - ( someWords8 - , prop_header_marshalling_id - , prop_handshake_marshalling_id - , prop_handshake13_marshalling_id - ) where - -import Control.Monad -import Control.Applicative -import Test.Tasty.QuickCheck -import Network.TLS.Internal -import Network.TLS - -import qualified Data.ByteString as B -import Data.Word -import Data.X509 (CertificateChain(..)) -import Certificate - -genByteString :: Int -> Gen B.ByteString -genByteString i = B.pack <$> vector i - -instance Arbitrary Version where - arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12, TLS13 ] - -instance Arbitrary ProtocolType where - arbitrary = elements - [ ProtocolType_ChangeCipherSpec - , ProtocolType_Alert - , ProtocolType_Handshake - , ProtocolType_AppData ] - -instance Arbitrary Header where - arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary ClientRandom where - arbitrary = ClientRandom <$> genByteString 32 - -instance Arbitrary ServerRandom where - arbitrary = ServerRandom <$> genByteString 32 - -instance Arbitrary Session where - arbitrary = do - i <- choose (1,2) :: Gen Int - case i of - 2 -> Session . Just <$> genByteString 32 - _ -> return $ Session Nothing - -instance Arbitrary HashAlgorithm where - arbitrary = elements - [ Network.TLS.HashNone - , Network.TLS.HashMD5 - , Network.TLS.HashSHA1 - , Network.TLS.HashSHA224 - , Network.TLS.HashSHA256 - , Network.TLS.HashSHA384 - , Network.TLS.HashSHA512 - , Network.TLS.HashIntrinsic - ] - -instance Arbitrary SignatureAlgorithm where - arbitrary = elements - [ SignatureAnonymous - , SignatureRSA - , SignatureDSS - , SignatureECDSA - , SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureEd25519 - , SignatureEd448 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] - -instance Arbitrary DigitallySigned where - arbitrary = DigitallySigned Nothing <$> genByteString 32 - -arbitraryCiphersIDs :: Gen [Word16] -arbitraryCiphersIDs = choose (0,200) >>= vector - -arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0,200) >>= vector - -someWords8 :: Int -> Gen [Word8] -someWords8 = vector - -instance Arbitrary ExtensionRaw where - arbitrary = - let arbitraryContent = choose (0,40) >>= genByteString - in ExtensionRaw <$> arbitrary <*> arbitraryContent - -arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] -arbitraryHelloExtensions ver - | ver >= SSL3 = arbitrary - | otherwise = return [] -- no hello extension with SSLv2 - -instance Arbitrary CertificateType where - arbitrary = elements - [ CertificateType_RSA_Sign, CertificateType_DSS_Sign - , CertificateType_RSA_Fixed_DH, CertificateType_DSS_Fixed_DH - , CertificateType_RSA_Ephemeral_DH, CertificateType_DSS_Ephemeral_DH - , CertificateType_fortezza_dms ] - -instance Arbitrary Handshake where - arbitrary = oneof - [ arbitrary >>= \ver -> ClientHello ver - <$> arbitrary - <*> arbitrary - <*> arbitraryCiphersIDs - <*> arbitraryCompressionIDs - <*> arbitraryHelloExtensions ver - <*> return Nothing - , arbitrary >>= \ver -> ServerHello ver - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryHelloExtensions ver - , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) - , pure HelloRequest - , pure ServerHelloDone - , ClientKeyXchg . CKX_RSA <$> genByteString 48 - --, liftM ServerKeyXchg - , liftM3 CertRequest arbitrary (return Nothing) (listOf arbitraryDN) - , CertVerify <$> arbitrary - , Finished <$> genByteString 12 - ] - -arbitraryCertReqContext :: Gen B.ByteString -arbitraryCertReqContext = oneof [ return B.empty, genByteString 32 ] - -instance Arbitrary Handshake13 where - arbitrary = oneof - [ arbitrary >>= \ver -> ClientHello13 ver - <$> arbitrary - <*> arbitrary - <*> arbitraryCiphersIDs - <*> arbitraryHelloExtensions ver - , arbitrary >>= \ver -> ServerHello13 - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryHelloExtensions ver - , NewSessionTicket13 - <$> arbitrary - <*> arbitrary - <*> genByteString 32 -- nonce - <*> genByteString 32 -- session ID - <*> arbitrary - , pure EndOfEarlyData13 - , EncryptedExtensions13 <$> arbitrary - , CertRequest13 - <$> arbitraryCertReqContext - <*> arbitrary - , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 - <$> arbitraryCertReqContext - <*> return (CertificateChain certs) - <*> replicateM (length certs) arbitrary - , CertVerify13 <$> arbitrary <*> genByteString 32 - , Finished13 <$> genByteString 12 - , KeyUpdate13 <$> elements [ UpdateNotRequested, UpdateRequested ] - ] - -{- quickcheck property -} - -prop_header_marshalling_id :: Header -> Bool -prop_header_marshalling_id x = decodeHeader (encodeHeader x) == Right x - -prop_handshake_marshalling_id :: Handshake -> Bool -prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x - where decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b - cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = Just CipherKeyExchange_RSA } - -prop_handshake13_marshalling_id :: Handshake13 -> Bool -prop_handshake13_marshalling_id x = decodeHs (encodeHandshake13 x) == Right x - where decodeHs b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b - -verifyResult :: (t -> b -> r) -> GetResult (t, b) -> r -verifyResult fn result = - case result of - GotPartial _ -> error "got partial" - GotError e -> error ("got error: " ++ show e) - GotSuccessRemaining _ _ -> error "got remaining byte left" - GotSuccess (ty, content) -> fn ty content diff --git a/Tests/PipeChan.hs b/Tests/PipeChan.hs deleted file mode 100644 --- a/Tests/PipeChan.hs +++ /dev/null @@ -1,70 +0,0 @@ --- create a similar concept than a unix pipe. -module PipeChan - ( PipeChan(..) - , newPipe - , runPipe - , readPipeA - , readPipeB - , writePipeA - , writePipeB - ) where - -import Control.Applicative -import Control.Concurrent.Chan -import Control.Concurrent -import Control.Monad (forever) -import Data.ByteString (ByteString) -import Data.IORef -import qualified Data.ByteString as B - --- | represent a unidirectional pipe with a buffered read channel and a write channel -data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) - -newUniPipeChan :: IO UniPipeChan -newUniPipeChan = UniPipeChan <$> newChan <*> newChan - -runUniPipe :: UniPipeChan -> IO ThreadId -runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w - -getReadUniPipe :: UniPipeChan -> Chan ByteString -getReadUniPipe (UniPipeChan r _) = r - -getWriteUniPipe :: UniPipeChan -> Chan ByteString -getWriteUniPipe (UniPipeChan _ w) = w - --- | Represent a bidirectional pipe with 2 nodes A and B -data PipeChan = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan - -newPipe :: IO PipeChan -newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan - -runPipe :: PipeChan -> IO ThreadId -runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC - -readPipeA :: PipeChan -> Int -> IO ByteString -readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz - -writePipeA :: PipeChan -> ByteString -> IO () -writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c - -readPipeB :: PipeChan -> Int -> IO ByteString -readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz - -writePipeB :: PipeChan -> ByteString -> IO () -writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s - --- helper to read buffered data. -readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString -readBuffered buf chan sz = do - left <- readIORef buf - if B.length left >= sz - then do - let (ret, nleft) = B.splitAt sz left - writeIORef buf nleft - return ret - else do - let newSize = (sz - B.length left) - newData <- readChan chan - writeIORef buf newData - remain <- readBuffered buf chan newSize - return (left `B.append` remain) diff --git a/Tests/PubKey.hs b/Tests/PubKey.hs deleted file mode 100644 --- a/Tests/PubKey.hs +++ /dev/null @@ -1,133 +0,0 @@ -module PubKey - ( arbitraryRSAPair - , arbitraryDSAPair - , arbitraryECDSAPair - , arbitraryEd25519Pair - , arbitraryEd448Pair - , globalRSAPair - , getGlobalRSAPair - , knownECCurves - , defaultECCurve - , dhParams512 - , dhParams768 - , dhParams1024 - , dsaParams - , rsaParams - ) where - -import Test.Tasty.QuickCheck - -import qualified Data.ByteString as B -import qualified Crypto.PubKey.DH as DH -import Crypto.Error -import Crypto.Random -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Prim as ECC -import qualified Crypto.PubKey.ECC.Types as ECC -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.Ed448 as Ed448 - -import Control.Concurrent.MVar -import System.IO.Unsafe - -arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) -arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary - where - rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey) - rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG - -arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey) -arbitraryRSAPairWithRNG = RSA.generate 256 0x10001 - -{-# NOINLINE globalRSAPair #-} -globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) -globalRSAPair = unsafePerformIO $ do - drg <- drgNew - newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG) - -{-# NOINLINE getGlobalRSAPair #-} -getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) -getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) - -rsaParams :: (RSA.PublicKey, RSA.PrivateKey) -rsaParams = (pub, priv) - where priv = RSA.PrivateKey { RSA.private_pub = pub - , RSA.private_d = d - , RSA.private_p = 0 - , RSA.private_q = 0 - , RSA.private_dP = 0 - , RSA.private_dQ = 0 - , RSA.private_qinv = 0 - } - pub = RSA.PublicKey { RSA.public_size = (1024 `div` 8), RSA.public_n = n, RSA.public_e = e } - n = 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 - e = 0x10001 - d = 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 - -dhParams512 :: DH.Params -dhParams512 = DH.Params - { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb - , DH.params_g = 0x2 - , DH.params_bits = 512 - } - --- from RFC 2409 - -dhParams768 :: DH.Params -dhParams768 = DH.Params - { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff - , DH.params_g = 0x2 - , DH.params_bits = 768 - } - -dhParams1024 :: DH.Params -dhParams1024 = DH.Params - { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff - , DH.params_g = 0x2 - , DH.params_bits = 1024 - } - -dsaParams :: DSA.Params -dsaParams = DSA.Params - { DSA.params_p = 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb - , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b - , DSA.params_g = 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff - } - -arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) -arbitraryDSAPair = do - priv <- choose (1, DSA.params_q dsaParams) - let pub = DSA.calculatePublic dsaParams priv - return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) - --- for performance reason P521 is not tested -knownECCurves :: [ECC.CurveName] -knownECCurves = [ ECC.SEC_p256r1 - , ECC.SEC_p384r1 - ] - -defaultECCurve :: ECC.CurveName -defaultECCurve = ECC.SEC_p256r1 - -arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey) -arbitraryECDSAPair curveName = do - d <- choose (1, n - 1) - let p = ECC.pointBaseMul curve d - return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d) - where - curve = ECC.getCurveByName curveName - n = ECC.ecc_n . ECC.common_curve $ curve - -arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) -arbitraryEd25519Pair = do - bytes <- vectorOf 32 arbitrary - let CryptoPassed priv = Ed25519.secretKey (B.pack bytes) - return (Ed25519.toPublic priv, priv) - -arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) -arbitraryEd448Pair = do - bytes <- vectorOf 57 arbitrary - let CryptoPassed priv = Ed448.secretKey (B.pack bytes) - return (Ed448.toPublic priv, priv) diff --git a/Tests/Tests.hs b/Tests/Tests.hs deleted file mode 100644 --- a/Tests/Tests.hs +++ /dev/null @@ -1,1054 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic - -import PipeChan -import Connection -import Marshalling -import Ciphers -import PubKey - -import Data.Foldable (traverse_) -import Data.Maybe -import Data.Default.Class -import Data.List (intersect) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as L -import Network.TLS -import Network.TLS.Extra -import Network.TLS.Internal -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.Async -import Control.Monad - -import Data.IORef -import Data.X509 (ExtKeyUsageFlag(..)) - -import System.Timeout - -prop_pipe_work :: PropertyM IO () -prop_pipe_work = do - pipe <- run newPipe - _ <- run (runPipe pipe) - - let bSize = 16 - n <- pick (choose (1, 32)) - - let d1 = B.replicate (bSize * n) 40 - let d2 = B.replicate (bSize * n) 45 - - d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) - d1 `assertEq` d1' - - d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) - d2 `assertEq` d2' - - return () - -chunkLengths :: Int -> [Int] -chunkLengths len - | len > 16384 = 16384 : chunkLengths (len - 16384) - | len > 0 = [len] - | otherwise = [] - -runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () -runTLSPipeN n params tlsServer tlsClient = do - -- generate some data to send - ds <- replicateM n $ do - d <- B.pack <$> pick (someWords8 256) - return d - -- send it - m_dsres <- run $ do - withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do - forM_ ds $ \d -> do - writeStart d - -- receive it - timeout 60000000 readResult -- 60 sec - case m_dsres of - Nothing -> error "timed out" - Just dsres -> ds `assertEq` dsres - -runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () -runTLSPipe = runTLSPipeN 1 - -runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO () -runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient - where tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - checkInfoPredicate ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - checkInfoPredicate ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - checkInfoPredicate ctx = do - minfo <- contextGetInformation ctx - unless (p minfo) $ - fail ("unexpected information: " ++ show minfo) - -runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSPipeSimple params = runTLSPipePredicate params (const True) - -runTLSPipeSimple13 :: (ClientParams, ServerParams) -> HandshakeMode13 -> Maybe C8.ByteString -> PropertyM IO () -runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient - where tlsServer ctx queue = do - handshake ctx - case mEarlyData of - Nothing -> return () - Just ed -> do - let ls = chunkLengths (B.length ed) - chunks <- replicateM (length ls) $ recvData ctx - (ls, ed) `assertEq` (map B.length chunks, B.concat chunks) - d <- recvData ctx - checkCtxFinished ctx - writeChan queue [d] - minfo <- contextGetInformation ctx - Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - minfo <- contextGetInformation ctx - Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) - byeBye ctx - -runTLSPipeCapture13 :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13]) -runTLSPipeCapture13 params = do - sRef <- run $ newIORef [] - cRef <- run $ newIORef [] - runTLSPipe params (tlsServer sRef) (tlsClient cRef) - sReceived <- run $ readIORef sRef - cReceived <- run $ readIORef cRef - return (reverse sReceived, reverse cReceived) - where tlsServer ref ctx queue = do - installHook ctx ref - handshake ctx - checkCtxFinished ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient ref queue ctx = do - installHook ctx ref - handshake ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - installHook ctx ref = - let recv hss = modifyIORef ref (hss :) >> return hss - in contextHookSetHandshake13Recv ctx recv - -runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient - where tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - d0 <- recvData ctx - req <- generate $ elements [OneWay, TwoWay] - _ <- updateKey ctx req - d1 <- recvData ctx - d2 <- recvData ctx - writeChan queue [d0,d1,d2] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - d0 <- readChan queue - sendData ctx (L.fromChunks [d0]) - d1 <- readChan queue - sendData ctx (L.fromChunks [d1]) - req <- generate $ elements [OneWay, TwoWay] - _ <- updateKey ctx req - d2 <- readChan queue - sendData ctx (L.fromChunks [d2]) - byeBye ctx - -runTLSInitFailureGen :: (ClientParams, ServerParams) -> (Context -> IO s) -> (Context -> IO c) -> PropertyM IO () -runTLSInitFailureGen params hsServer hsClient = do - (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) - assertIsLeft cRes - assertIsLeft sRes - where tlsServer ctx = do - _ <- hsServer ctx - checkCtxFinished ctx - minfo <- contextGetInformation ctx - byeBye ctx - return $ "server success: " ++ show minfo - tlsClient ctx = do - _ <- hsClient ctx - checkCtxFinished ctx - minfo <- contextGetInformation ctx - byeBye ctx - return $ "client success: " ++ show minfo - -runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSInitFailure params = runTLSInitFailureGen params handshake handshake - -prop_handshake_initiate :: PropertyM IO () -prop_handshake_initiate = do - params <- pick arbitraryPairParams - runTLSPipeSimple params - -prop_handshake13_initiate :: PropertyM IO () -prop_handshake13_initiate = do - params <- pick arbitraryPairParams13 - let cgrps = supportedGroups $ clientSupported $ fst params - sgrps = supportedGroups $ serverSupported $ snd params - hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest - runTLSPipeSimple13 params hs Nothing - -prop_handshake_keyupdate :: PropertyM IO () -prop_handshake_keyupdate = do - params <- pick arbitraryPairParams - runTLSPipeSimpleKeyUpdate params - -prop_handshake13_downgrade :: PropertyM IO () -prop_handshake13_downgrade = do - (cparam,sparam) <- pick arbitraryPairParams - versionForced <- pick $ elements (supportedVersions $ clientSupported cparam) - let debug' = (serverDebug sparam) { debugVersionForced = Just versionForced } - sparam' = sparam { serverDebug = debug' } - params = (cparam,sparam') - downgraded = (isVersionEnabled TLS13 params && versionForced < TLS13) || - (isVersionEnabled TLS12 params && versionForced < TLS12) - if downgraded - then runTLSInitFailure params - else runTLSPipeSimple params - -prop_handshake13_full :: PropertyM IO () -prop_handshake13_full = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported } - ) - runTLSPipeSimple13 params FullHandshake Nothing - -prop_handshake13_hrr :: PropertyM IO () -prop_handshake13_hrr = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256,X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported } - ) - runTLSPipeSimple13 params HelloRetryRequest Nothing - -prop_handshake13_psk :: PropertyM IO () -prop_handshake13_psk = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256,X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPipeSimple13 params2 PreSharedKey Nothing - -prop_handshake13_psk_fallback :: PropertyM IO () -prop_handshake13_psk_fallback = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES128CCM_SHA256 - ] - , supportedGroups = [P256,X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- 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 <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params - srv2' = srv2 { serverSupported = svrSupported' } - svrSupported' = def - { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] - , supportedGroups = [P256] - } - - runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing - -prop_handshake13_rtt0 :: PropertyM IO () -prop_handshake13_rtt0 = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256,X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - cliHooks = def { - onSuggestALPN = return $ Just ["h2"] - } - svrHooks = def { - onALPNClientSuggest = Just (\protos -> return $ head protos) - } - params0 = (cli { clientSupported = cliSupported - , clientHooks = cliHooks - } - ,srv { serverSupported = svrSupported - , serverHooks = svrHooks - , serverEarlyDataSize = 2048 } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - earlyData <- B.pack <$> pick (someWords8 256) - let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params - params2 = (pc { clientEarlyData = Just earlyData } , ps) - - runTLSPipeSimple13 params2 RTT0 (Just earlyData) - -prop_handshake13_rtt0_fallback :: PropertyM IO () -prop_handshake13_rtt0_fallback = do - ticketSize <- pick $ choose (0, 512) - (cli, srv) <- pick arbitraryPairParams13 - group0 <- pick $ elements [P256,X25519] - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256,X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [group0] - } - params0 = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported - , serverEarlyDataSize = ticketSize } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - let mode = if group0 == P256 then FullHandshake else HelloRetryRequest - runTLSPipeSimple13 params mode Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - earlyData <- B.pack <$> pick (someWords8 256) - group2 <- pick $ elements [P256,X25519] - let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params - svrSupported2 = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [group2] - } - params2 = (pc { clientEarlyData = Just earlyData } - ,ps { serverEarlyDataSize = 0 - , serverSupported = svrSupported2 - } - ) - - let mode2 = if ticketSize < 256 then PreSharedKey else RTT0 - runTLSPipeSimple13 params2 mode2 Nothing - -prop_handshake13_rtt0_length :: PropertyM IO () -prop_handshake13_rtt0_length = do - serverMax <- pick $ choose (0, 33792) - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - svrSupported = def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported - , serverEarlyDataSize = serverMax } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - let params = setPairParamsSessionManagers sessionManagers params0 - runTLSPipeSimple13 params FullHandshake Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - clientLen <- pick $ choose (0, 33792) - earlyData <- B.pack <$> pick (someWords8 clientLen) - let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params - params2 = (pc { clientEarlyData = Just earlyData } , ps) - (mode, mEarlyData) - | clientLen > serverMax = (PreSharedKey, Nothing) - | otherwise = (RTT0, Just earlyData) - runTLSPipeSimple13 params2 mode mEarlyData - -prop_handshake13_ee_groups :: PropertyM IO () -prop_handshake13_ee_groups = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = (clientSupported cli) { supportedGroups = [P256,X25519] } - svrSupported = (serverSupported srv) { supportedGroups = [X25519,P256] } - params = (cli { clientSupported = cliSupported } - ,srv { serverSupported = svrSupported } - ) - (_, serverMessages) <- runTLSPipeCapture13 params - let isNegotiatedGroups (ExtensionRaw eid _) = eid == 0xa - eeMessagesHaveExt = [ any isNegotiatedGroups exts | - EncryptedExtensions13 exts <- serverMessages ] - [True] `assertEq` eeMessagesHaveExt -- one EE message with extension - -prop_handshake_ciphersuites :: PropertyM IO () -prop_handshake_ciphersuites = do - tls13 <- pick arbitrary - let version = if tls13 then TLS13 else TLS12 - clientCiphers <- pick arbitraryCiphers - serverCiphers <- pick arbitraryCiphers - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (clientCiphers, serverCiphers) - let adequate = cipherAllowedForVersion version - shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) - if shouldSucceed - then runTLSPipeSimple (clientParam,serverParam) - else runTLSInitFailure (clientParam,serverParam) - -prop_handshake_hashsignatures :: PropertyM IO () -prop_handshake_hashsignatures = do - tls13 <- pick arbitrary - let version = if tls13 then TLS13 else TLS12 - ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_ECDHE_ECDSA_AES128CBC_SHA - , cipher_DHE_RSA_AES128_SHA1 - , cipher_DHE_DSS_AES128_SHA1 - , cipher_TLS13_AES128GCM_SHA256 - ] - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (ciphers, ciphers) - clientHashSigs <- pick $ arbitraryHashSignatures version - serverHashSigs <- pick $ arbitraryHashSignatures version - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedHashSignatures = clientHashSigs } - } - serverParam' = serverParam { serverSupported = (serverSupported serverParam) - { supportedHashSignatures = serverHashSigs } - } - commonHashSigs = clientHashSigs `intersect` serverHashSigs - shouldFail - | tls13 = all incompatibleWithDefaultCurve commonHashSigs - | otherwise = null commonHashSigs - if shouldFail - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') - where - incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 - incompatibleWithDefaultCurve _ = False - --- Tests ability to use or ignore client "signature_algorithms" extension when --- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but --- the server RSA certificate has a SHA-1 signature that the client does not --- support. Server may choose the DSA certificate only when cipher --- DHE_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA --- certificate. -prop_handshake_cert_fallback :: PropertyM IO () -prop_handshake_cert_fallback = do - let clientVersions = [TLS12] - serverVersions = [TLS12] - commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] - otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_DHE_DSS_AES128_SHA1 - ] - hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] - chainRef <- run $ newIORef Nothing - clientCiphers <- pick $ sublistOf otherCiphers - serverCiphers <- pick $ sublistOf otherCiphers - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedHashSignatures = hashSignatures } - , clientHooks = (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] } - } - dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers - || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers - runTLSPipeSimple (clientParam',serverParam) - serverChain <- run $ readIORef chainRef - dssDisallowed `assertEq` isLeafRSA serverChain - --- Same as above but testing with supportedHashSignatures directly instead of --- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the --- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by --- both client and server, the Ed25519 certificate is selected. Otherwise the --- server fallbacks to RSA. --- --- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 --- unless client advertises explicit support. Currently this is not enforced by --- the library, which is useful to test this scenario. SHA-1 could be replaced --- by another algorithm. -prop_handshake_cert_fallback_hs :: PropertyM IO () -prop_handshake_cert_fallback_hs = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = [ cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_ECDSA_AES128GCM_SHA256 - , cipher_TLS13_AES128GCM_SHA256 - ] - commonHS = [ (HashSHA256, SignatureRSA) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) - ] - otherHS = [ (HashIntrinsic, SignatureEd25519) ] - chainRef <- run $ newIORef Nothing - clientHS <- pick $ sublistOf otherHS - serverHS <- pick $ sublistOf otherHS - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedHashSignatures = commonHS ++ clientHS } - , clientHooks = (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] } - } - serverParam' = serverParam { serverSupported = (serverSupported serverParam) - { supportedHashSignatures = commonHS ++ serverHS } - } - eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS - || (HashIntrinsic, SignatureEd25519) `notElem` serverHS - runTLSPipeSimple (clientParam',serverParam') - serverChain <- run $ readIORef chainRef - eddsaDisallowed `assertEq` isLeafRSA serverChain - -prop_handshake_groups :: PropertyM IO () -prop_handshake_groups = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_DHE_RSA_AES256GCM_SHA384 - , cipher_DHE_RSA_AES128_SHA1 - , cipher_TLS13_AES128GCM_SHA256 - ] - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - clientGroups <- pick arbitraryGroups - serverGroups <- pick arbitraryGroups - denyCustom <- pick arbitrary - let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid - clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedGroups = clientGroups } - , clientHooks = (clientHooks clientParam) - { onCustomFFDHEGroup = \_ _ -> return groupUsage } - } - serverParam' = serverParam { serverSupported = (serverSupported serverParam) - { supportedGroups = serverGroups } - } - isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') - mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup - isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup - commonGroups = clientGroups `intersect` serverGroups - shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) - p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom) - if shouldFail - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipePredicate (clientParam',serverParam') p - - -prop_handshake_dh :: PropertyM IO () -prop_handshake_dh = do - let clientVersions = [TLS12] - serverVersions = [TLS12] - ciphers = [ cipher_DHE_RSA_AES128_SHA1 ] - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (ciphers, ciphers) - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedGroups = [] } - } - let check (dh,shouldFail) = do - let serverParam' = serverParam { serverDHEParams = Just dh } - if shouldFail - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') - mapM_ check [(dhParams512,True) - ,(dhParams768,True) - ,(dhParams1024,False)] - -prop_handshake_srv_key_usage :: PropertyM IO () -prop_handshake_srv_key_usage = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3] - ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_TLS13_AES128GCM_SHA256 - , cipher_DHE_RSA_AES128_SHA1 - , cipher_AES256_SHA256 - ] - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - usageFlags <- pick arbitraryKeyUsage - cred <- pick $ arbitraryRSACredentialWithUsage usageFlags - let serverParam' = serverParam - { serverShared = (serverShared serverParam) - { sharedCredentials = Credentials [cred] - } - } - hasDS = KeyUsage_digitalSignature `elem` usageFlags - hasKE = KeyUsage_keyEncipherment `elem` usageFlags - shouldSucceed = hasDS || (hasKE && not tls13) - if shouldSucceed - then runTLSPipeSimple (clientParam,serverParam') - else runTLSInitFailure (clientParam,serverParam') - -prop_handshake_ec :: PropertyM IO () -prop_handshake_ec = do - let versions = [TLS10, TLS11, TLS12, TLS13] - ciphers = [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_AES128CBC_SHA - , cipher_TLS13_AES128GCM_SHA256 - ] - sigGroups = [P256] - ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure - hashSignatures = [ (HashSHA256, SignatureECDSA) - ] - clientVersion <- pick $ elements versions - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - ([clientVersion], versions) - (ciphers, ciphers) - clientGroups <- pick $ sublistOf sigGroups - clientHashSignatures <- pick $ sublistOf hashSignatures - serverHashSignatures <- pick $ sublistOf hashSignatures - credentials <- pick arbitraryCredentialsOfEachCurve - let clientParam' = clientParam { clientSupported = (clientSupported clientParam) - { supportedGroups = clientGroups ++ ecdhGroups - , supportedHashSignatures = clientHashSignatures - } - } - serverParam' = serverParam { serverSupported = (serverSupported serverParam) - { supportedGroups = sigGroups ++ ecdhGroups - , supportedHashSignatures = serverHashSignatures - } - , serverShared = (serverShared serverParam) - { sharedCredentials = Credentials credentials } - } - sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) - ecdsaDenied = (clientVersion < TLS13 && null clientGroups) || - (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs) - if ecdsaDenied - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') - -prop_handshake_client_auth :: PropertyM IO () -prop_handshake_client_auth = do - (clientParam,serverParam) <- pick arbitraryPairParams - let clientVersions = supportedVersions $ clientSupported clientParam - serverVersions = supportedVersions $ serverSupported serverParam - version = maximum (clientVersions `intersect` serverVersions) - cred <- pick (arbitraryClientCredential version) - let clientParam' = clientParam { clientHooks = (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred } - } - serverParam' = serverParam { serverWantClientCert = True - , serverHooks = (serverHooks serverParam) - { onClientCertificate = validateChain cred } - } - let shouldFail = version == TLS13 && isCredentialDSA cred - if shouldFail - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') - where validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - -prop_post_handshake_auth :: PropertyM IO () -prop_post_handshake_auth = do - (clientParam,serverParam) <- pick arbitraryPairParams13 - cred <- pick (arbitraryClientCredential TLS13) - let clientParam' = clientParam { clientHooks = (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred } - } - serverParam' = serverParam { serverHooks = (serverHooks serverParam) - { onClientCertificate = validateChain cred } - } - if isCredentialDSA cred - then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient - else runTLSPipe (clientParam',serverParam') tlsServer tlsClient - where validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - tlsServer ctx queue = do - hsServer ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - hsClient ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - hsServer ctx = do - handshake ctx - checkCtxFinished ctx - recvDataAssert ctx "request 1" - _ <- requestCertificate ctx -- single request - sendData ctx "response 1" - recvDataAssert ctx "request 2" - _ <- requestCertificate ctx - _ <- requestCertificate ctx -- two simultaneously - sendData ctx "response 2" - hsClient ctx = do - handshake ctx - checkCtxFinished ctx - sendData ctx "request 1" - recvDataAssert ctx "response 1" - sendData ctx "request 2" - recvDataAssert ctx "response 2" - -prop_handshake_clt_key_usage :: PropertyM IO () -prop_handshake_clt_key_usage = do - (clientParam,serverParam) <- pick arbitraryPairParams - usageFlags <- pick arbitraryKeyUsage - cred <- pick $ arbitraryRSACredentialWithUsage usageFlags - let clientParam' = clientParam { clientHooks = (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred } - } - serverParam' = serverParam { serverWantClientCert = True - , serverHooks = (serverHooks serverParam) - { onClientCertificate = \_ -> return CertificateUsageAccept } - } - shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags - if shouldSucceed - then runTLSPipeSimple (clientParam',serverParam') - else runTLSInitFailure (clientParam',serverParam') - -prop_handshake_ems :: PropertyM IO () -prop_handshake_ems = do - (cems, sems) <- pick arbitraryEMSMode - params <- pick arbitraryPairParams - let params' = setEMSMode (cems, sems) params - version = getConnectVersion params' - emsVersion = version >= TLS10 && version <= TLS12 - use = cems /= NoEMS && sems /= NoEMS - require = cems == RequireEMS || sems == RequireEMS - p info = infoExtendedMasterSec info == (emsVersion && use) - if emsVersion && require && not use - then runTLSInitFailure params' - else runTLSPipePredicate params' (maybe False p) - -prop_handshake_session_resumption_ems :: PropertyM IO () -prop_handshake_session_resumption_ems = do - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - plainParams <- pick arbitraryPairParams - ems <- pick (arbitraryEMSMode `suchThat` compatible) - let params = setEMSMode ems $ - setPairParamsSessionManagers sessionManagers plainParams - - runTLSPipeSimple params - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - ems2 <- pick (arbitraryEMSMode `suchThat` compatible) - let params2 = setEMSMode ems2 $ - setPairParamsSessionResuming (fromJust sessionParams) params - - let version = getConnectVersion params2 - emsVersion = version >= TLS10 && version <= TLS12 - - if emsVersion && use ems && not (use ems2) - then runTLSInitFailure params2 - else do - runTLSPipeSimple params2 - sessionParams2 <- run $ readClientSessionRef sessionRefs - let sameSession = sessionParams == sessionParams2 - sameUse = use ems == use ems2 - when emsVersion $ assert (sameSession == sameUse) - where - compatible (NoEMS, RequireEMS) = False - compatible (RequireEMS, NoEMS) = False - compatible _ = True - - use (NoEMS, _) = False - use (_, NoEMS) = False - use _ = True - -prop_handshake_alpn :: PropertyM IO () -prop_handshake_alpn = do - (clientParam,serverParam) <- pick arbitraryPairParams - let clientParam' = clientParam { clientHooks = (clientHooks clientParam) - { onSuggestALPN = return $ Just ["h2", "http/1.1"] } - } - serverParam' = serverParam { serverHooks = (serverHooks serverParam) - { onALPNClientSuggest = Just alpn } - } - params' = (clientParam',serverParam') - runTLSPipe params' tlsServer tlsClient - where tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - proto <- getNegotiatedProtocol ctx - Just "h2" `assertEq` proto - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - proto <- getNegotiatedProtocol ctx - Just "h2" `assertEq` proto - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - alpn xs - | "h2" `elem` xs = return "h2" - | otherwise = return "http/1.1" - -prop_handshake_sni :: PropertyM IO () -prop_handshake_sni = do - ref <- run $ newIORef Nothing - (clientParam,serverParam) <- pick arbitraryPairParams - let clientParam' = clientParam { clientServerIdentification = (serverName, "") - } - serverParam' = serverParam { serverHooks = (serverHooks serverParam) - { onServerNameIndication = onSNI ref } - } - params' = (clientParam',serverParam') - runTLSPipe params' tlsServer tlsClient - receivedName <- run $ readIORef ref - Just (Just serverName) `assertEq` receivedName - where tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - sni <- getClientSNI ctx - Just serverName `assertEq` sni - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - sni <- getClientSNI ctx - Just serverName `assertEq` sni - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >> - return (Credentials []) - serverName = "haskell.org" - -prop_handshake_renegotiation :: PropertyM IO () -prop_handshake_renegotiation = do - renegDisabled <- pick arbitrary - (cparams, sparams) <- pick arbitraryPairParams - let sparams' = sparams { - serverSupported = (serverSupported sparams) { - supportedClientInitiatedRenegotiation = not renegDisabled - } - } - if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') - then runTLSInitFailureGen (cparams, sparams') hsServer hsClient - else runTLSPipe (cparams, sparams') tlsServer tlsClient - where tlsServer ctx queue = do - hsServer ctx - checkCtxFinished ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - hsClient ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - hsServer = handshake - hsClient ctx = handshake ctx >> handshake ctx - -prop_handshake_session_resumption :: PropertyM IO () -prop_handshake_session_resumption = do - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - plainParams <- pick arbitraryPairParams - let params = setPairParamsSessionManagers sessionManagers plainParams - - runTLSPipeSimple params - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPipeSimple params2 - -prop_thread_safety :: PropertyM IO () -prop_thread_safety = do - params <- pick arbitraryPairParams - runTLSPipe params tlsServer tlsClient - where tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - runReaderWriters ctx "client-value" "server-value" - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - runReaderWriters ctx "server-value" "client-value" - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - runReaderWriters ctx r w = - -- run concurrently 10 readers and 10 writers on the same context - let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] - in runConcurrently $ traverse_ Concurrently workers - -assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () -assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) - -assertIsLeft :: (Show b, Monad m) => Either a b -> m () -assertIsLeft (Left _) = return () -assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") - -assertEmptyRef :: Show a => IORef (Maybe a) -> IO () -assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a -> - error ("got " ++ show a ++ " but was expecting empty reference")) - -recvDataAssert :: Context -> C8.ByteString -> IO () -recvDataAssert ctx expected = do - got <- recvData ctx - assertEq expected got - -checkCtxFinished :: Context -> IO () -checkCtxFinished ctx = do - ctxFinished <- getFinished ctx - unless (isJust ctxFinished) $ - fail "unexpected ctxFinished" - ctxPeerFinished <- getPeerFinished ctx - unless (isJust ctxPeerFinished) $ - fail "unexpected ctxPeerFinished" - -main :: IO () -main = defaultMain $ testGroup "tls" - [ tests_marshalling - , tests_ciphers - , tests_handshake - , tests_thread_safety - ] - where -- lowlevel tests to check the packet marshalling. - tests_marshalling = testGroup "Marshalling" - [ testProperty "Header" prop_header_marshalling_id - , testProperty "Handshake" prop_handshake_marshalling_id - , testProperty "Handshake13" prop_handshake13_marshalling_id - ] - tests_ciphers = testGroup "Ciphers" - [ testProperty "Bulk" propertyBulkFunctional ] - - -- high level tests between a client and server with fake ciphers. - tests_handshake = testGroup "Handshakes" - [ testProperty "Setup" (monadicIO prop_pipe_work) - , testProperty "Initiation" (monadicIO prop_handshake_initiate) - , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate) - , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate) - , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) - , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) - , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) - , testProperty "Groups" (monadicIO prop_handshake_groups) - , testProperty "Elliptic curves" (monadicIO prop_handshake_ec) - , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback) - , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs) - , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) - , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) - , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) - , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) - , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems) - , testProperty "ALPN" (monadicIO prop_handshake_alpn) - , testProperty "SNI" (monadicIO prop_handshake_sni) - , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) - , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) - , testProperty "Custom DH" (monadicIO prop_handshake_dh) - , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full) - , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr) - , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk) - , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback) - , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) - , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) - , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) - , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups) - , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) - ] - - -- test concurrent reads and writes - tests_thread_safety = localOption (QuickCheckTests 10) $ - testProperty "Thread safety" (monadicIO prop_thread_safety) diff --git a/test/API.hs b/test/API.hs new file mode 100644 --- /dev/null +++ b/test/API.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module API where + +import Control.Applicative +import Control.Monad +import Data.ByteString (ByteString) +import Data.Maybe +import Network.TLS +import Test.Hspec + +checkCtxFinished :: Context -> IO () +checkCtxFinished ctx = do + mUnique <- getTLSUnique ctx + mExporter <- getTLSExporter ctx + when (isNothing (mUnique <|> mExporter)) $ + fail "unexpected channel binding" + +recvDataAssert :: Context -> ByteString -> IO () +recvDataAssert ctx expected = do + got <- recvData ctx + got `shouldBe` expected diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Arbitrary.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Arbitrary where + +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 Network.TLS +import Network.TLS.Extra.Cipher +import Network.TLS.Internal +import Test.QuickCheck + +import Certificate +import PubKey + +---------------------------------------------------------------- + +instance Arbitrary Version where + arbitrary = elements [TLS12, TLS13] + +instance Arbitrary ProtocolType where + arbitrary = + elements + [ ProtocolType_ChangeCipherSpec + , ProtocolType_Alert + , ProtocolType_Handshake + , ProtocolType_AppData + ] + +instance Arbitrary Header where + arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ClientRandom where + arbitrary = ClientRandom <$> genByteString 32 + +instance Arbitrary ServerRandom where + arbitrary = ServerRandom <$> genByteString 32 + +instance Arbitrary Session where + arbitrary = do + i <- choose (1, 2) :: Gen Int + case i of + 2 -> Session . Just <$> genByteString 32 + _ -> return $ Session Nothing + +instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where + arbitrary = shuffle supportedSignatureSchemes + +instance Arbitrary DigitallySigned where + arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32 + +instance Arbitrary ExtensionRaw where + arbitrary = + let arbitraryContent = choose (0, 40) >>= genByteString + in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent + +instance Arbitrary CertificateType where + arbitrary = + elements + [ CertificateType_RSA_Sign + , CertificateType_DSA_Sign + , CertificateType_ECDSA_Sign + ] + +instance Arbitrary Handshake where + arbitrary = + oneof + [ arbitrary >>= \ver -> do + ClientHello ver + <$> arbitrary + <*> arbitraryCompressionIDs + <*> (CH <$> arbitrary <*> arbitraryCiphersIDs <*> arbitraryHelloExtensions ver) + , arbitrary >>= \ver -> + ServerHello ver + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver + , Certificate . CertificateChain <$> resize 2 (listOf arbitraryX509) + , pure HelloRequest + , pure ServerHelloDone + , ClientKeyXchg . CKX_RSA <$> genByteString 48 + , CertRequest <$> arbitrary <*> arbitrary <*> listOf arbitraryDN + , CertVerify <$> arbitrary + , Finished <$> genByteString 12 + ] + +instance Arbitrary Handshake13 where + arbitrary = + oneof + [ arbitrary >>= \ver -> + ServerHello13 + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver + , NewSessionTicket13 + <$> arbitrary + <*> arbitrary + <*> genByteString 32 -- nonce + <*> genByteString 32 -- session ID + <*> arbitrary + , pure EndOfEarlyData13 + , EncryptedExtensions13 <$> arbitrary + , CertRequest13 + <$> arbitraryCertReqContext + <*> arbitrary + , resize 2 (listOf arbitraryX509) >>= \certs -> + Certificate13 + <$> arbitraryCertReqContext + <*> return (CertificateChain certs) + <*> replicateM (length certs) arbitrary + , CertVerify13 <$> (head <$> arbitrary) <*> genByteString 32 + , Finished13 <$> genByteString 12 + , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] + ] + +---------------------------------------------------------------- + +arbitraryCiphersIDs :: Gen [Word16] +arbitraryCiphersIDs = choose (0, 200) >>= vector + +arbitraryCompressionIDs :: Gen [Word8] +arbitraryCompressionIDs = choose (0, 200) >>= vector + +someWords8 :: Int -> Gen [Word8] +someWords8 = vector + +arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] +arbitraryHelloExtensions _ver = arbitrary + +arbitraryCertReqContext :: Gen B.ByteString +arbitraryCertReqContext = oneof [return B.empty, genByteString 32] + +---------------------------------------------------------------- + +knownCiphers :: [Cipher] +knownCiphers = ciphersuite_all + +instance Arbitrary Cipher where + arbitrary = elements knownCiphers + +knownVersions :: [Version] +knownVersions = [TLS13, TLS12] + +arbitraryVersions :: Gen [Version] +arbitraryVersions = sublistOf knownVersions + +-- for performance reason P521, FFDHE6144, FFDHE8192 are not tested +knownGroups, knownECGroups, knownFFGroups :: [Group] +knownECGroups = [P256, P384, X25519, X448] +knownFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096] +knownGroups = knownECGroups ++ knownFFGroups + +defaultECGroup :: Group +defaultECGroup = P256 -- same as defaultECCurve + +otherKnownECGroups :: [Group] +otherKnownECGroups = filter (/= defaultECGroup) knownECGroups + +instance Arbitrary Group where + arbitrary = elements knownGroups + +instance {-# OVERLAPS #-} Arbitrary [Group] where + arbitrary = sublistOf knownGroups + +newtype EC = EC [Group] deriving (Show) + +instance Arbitrary EC where + arbitrary = EC <$> shuffle knownECGroups + +newtype FFDHE = FFDHE [Group] deriving (Show) + +instance Arbitrary FFDHE where + arbitrary = FFDHE <$> shuffle knownFFGroups + +isCredentialDSA :: (CertificateChain, PrivKey) -> Bool +isCredentialDSA (_, PrivKeyDSA _) = True +isCredentialDSA _ = False + +---------------------------------------------------------------- + +arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle + +arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachType' = do + let (pubKey, privKey) = getGlobalRSAPair + curveName = defaultECCurve + (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName + (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair + (ed448Pub, ed448Priv) <- arbitraryEd448Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + [ (PubKeyRSA pubKey, PrivKeyRSA privKey) + , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) + , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) + , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) + ] + +arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle + +arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachCurve' = do + ecdsaPairs <- + mapM + ( \curveName -> do + (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName + return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) + ) + knownECCurves + (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair + (ed448Pub, ed448Priv) <- arbitraryEd448Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) + , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) + ] + ++ ecdsaPairs + +---------------------------------------------------------------- + +leafPublicKey :: CertificateChain -> Maybe PubKey +leafPublicKey (CertificateChain []) = Nothing +leafPublicKey (CertificateChain (leaf : _)) = Just (certPubKey $ getCertificate leaf) + +isLeafRSA :: Maybe CertificateChain -> Bool +isLeafRSA chain = case chain >>= leafPublicKey of + Just (PubKeyRSA _) -> True + _ -> False + +arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) +arbitraryCipherPair connectVersion = do + serverCiphers <- + arbitrary + `suchThat` (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) + clientCiphers <- + arbitrary + `suchThat` ( \cs -> + or + [ x `elem` serverCiphers + && cipherAllowedForVersion connectVersion x + | x <- cs + ] + ) + return (clientCiphers, serverCiphers) + +---------------------------------------------------------------- + +instance {-# OVERLAPS #-} Arbitrary (ClientParams, ServerParams) where + arbitrary = elements knownVersions >>= arbitraryPairParamsAt + +---------------------------------------------------------------- + +data GGP = GGP [Group] [Group] deriving (Show) + +instance Arbitrary GGP where + arbitrary = arbitraryGroupPair + +-- Pair of groups so that at least the default EC group P256 and one FF group +-- are in common. This makes DHE and ECDHE ciphers always compatible with +-- extension "Supported Elliptic Curves" / "Supported Groups". +arbitraryGroupPair :: Gen GGP +arbitraryGroupPair = do + (serverECGroups, clientECGroups) <- + arbitraryGroupPairWith defaultECGroup otherKnownECGroups + serverGroups <- shuffle serverECGroups + clientGroups <- shuffle clientECGroups + return $ GGP clientGroups serverGroups + where + arbitraryGroupPairWith e es = do + s <- sublistOf es + c <- sublistOf es + return (e : s, e : c) + +---------------------------------------------------------------- + +arbitraryPairParams12 :: Gen (ClientParams, ServerParams) +arbitraryPairParams12 = arbitraryPairParamsAt TLS12 + +arbitraryPairParams13 :: Gen (ClientParams, ServerParams) +arbitraryPairParams13 = arbitraryPairParamsAt TLS13 + +arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) +arbitraryPairParamsAt connectVersion = do + (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion + -- Select version lists containing connectVersion, as well as some other + -- 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 + ] + ] + allowedVersionsFiltered = filter (<= connectVersion) allowedVersions + -- Server or client is allowed to have versions > connectVersion, but not + -- both simultaneously. + filterSrv <- arbitrary + let (clientAllowedVersions, serverAllowedVersions) + | filterSrv = (allowedVersions, allowedVersionsFiltered) + | otherwise = (allowedVersionsFiltered, allowedVersions) + -- Generate version lists containing less than 127 elements, otherwise the + -- "supported_versions" extension cannot be correctly serialized + clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions + serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers, serverCiphers) + where + listWithOthers :: a -> Int -> [a] -> Gen [a] + listWithOthers fixedElement maxOthers others + | maxOthers < 1 = return [fixedElement] + | otherwise = sized $ \n -> do + num <- choose (0, min n maxOthers) + pos <- choose (0, num) + prefix <- vectorOf pos $ elements others + suffix <- vectorOf (num - pos) $ elements others + return $ prefix ++ (fixedElement : suffix) + +---------------------------------------------------------------- + +getConnectVersion :: (ClientParams, ServerParams) -> Version +getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) + where + sver = supportedVersions (serverSupported sparams) + cver = supportedVersions (clientSupported cparams) + +isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool +isVersionEnabled ver (cparams, sparams) = + (ver `elem` supportedVersions (serverSupported sparams)) + && (ver `elem` supportedVersions (clientSupported cparams)) + +arbitraryPairParamsWithVersionsAndCiphers + :: ([Version], [Version]) + -> ([Cipher], [Cipher]) + -> Gen (ClientParams, ServerParams) +arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do + secNeg <- arbitrary + + creds <- arbitraryCredentialsOfEachType + GGP clientGroups serverGroups <- arbitraryGroupPair + clientHashSignatures <- arbitrary + serverHashSignatures <- arbitrary + let serverState = + def + { serverSupported = + def + { supportedCiphers = serverCiphers + , supportedVersions = serverVersions + , supportedSecureRenegotiation = secNeg + , supportedGroups = serverGroups + , supportedHashSignatures = serverHashSignatures + } + , serverShared = def{sharedCredentials = Credentials creds} + } + let clientState = + (defaultParamsClient "" B.empty) + { clientSupported = + def + { supportedCiphers = clientCiphers + , supportedVersions = clientVersions + , supportedSecureRenegotiation = secNeg + , supportedGroups = clientGroups + , supportedHashSignatures = clientHashSignatures + } + , clientShared = + def + { sharedValidationCache = + ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } + } + return (clientState, serverState) + +arbitraryClientCredential :: Version -> Gen Credential +arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements + +arbitraryRSACredentialWithUsage + :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) +arbitraryRSACredentialWithUsage usageFlags = do + let (pubKey, privKey) = getGlobalRSAPair + cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) + return (CertificateChain [cert], PrivKeyRSA privKey) + +instance {-# OVERLAPS #-} Arbitrary (EMSMode, EMSMode) where + arbitrary = (,) <$> gen <*> gen + where + gen = elements [NoEMS, AllowEMS, RequireEMS] + +setEMSMode + :: (EMSMode, EMSMode) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') + where + clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedExtendedMainSecret = cems + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedExtendedMainSecret = sems + } + } + +genByteString :: Int -> Gen B.ByteString +genByteString i = B.pack <$> vector i diff --git a/test/Certificate.hs b/test/Certificate.hs new file mode 100644 --- /dev/null +++ b/test/Certificate.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Certificate ( + arbitraryX509, + arbitraryX509WithKey, + arbitraryX509WithKeyAndUsage, + arbitraryDN, + simpleCertificate, + simpleX509, + toPubKeyEC, + toPrivKeyEC, +) where + +import Crypto.Number.Serialize (i2ospOf_) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECC +import Data.ASN1.OID +import qualified Data.ByteString as B +import Data.Hourglass +import Data.X509 +import Test.QuickCheck + +import PubKey + +arbitraryDN :: Gen DistinguishedName +arbitraryDN = return $ DistinguishedName [] + +instance Arbitrary Date where + arbitrary = do + y <- choose (1971, 2035) + m <- elements [January .. December] + d <- choose (1, 30) + return $ normalizeDate $ Date y m d + +normalizeDate :: Date -> Date +normalizeDate d = timeConvert (timeConvert d :: Elapsed) + +instance Arbitrary TimeOfDay where + arbitrary = do + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) + let nsec = 0 + return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec + +instance Arbitrary DateTime where + arbitrary = DateTime <$> arbitrary <*> arbitrary + +maxSerial :: Integer +maxSerial = 16777216 + +arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate +arbitraryCertificate usageFlags pubKey = do + serial <- choose (0, maxSerial) + subjectdn <- arbitraryDN + validity <- (,) <$> arbitrary <*> arbitrary + let sigalg = getSignatureALG pubKey + return $ + Certificate + { certVersion = 3 + , certSerial = serial + , certSignatureAlg = sigalg + , certIssuerDN = issuerdn + , certSubjectDN = subjectdn + , certValidity = validity + , certPubKey = pubKey + , certExtensions = + Extensions $ + Just + [ extensionEncode True $ ExtKeyUsage usageFlags + ] + } + where + issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] + +simpleCertificate :: PubKey -> Certificate +simpleCertificate pubKey = + Certificate + { certVersion = 3 + , certSerial = 0 + , certSignatureAlg = getSignatureALG pubKey + , certIssuerDN = simpleDN + , certSubjectDN = simpleDN + , certValidity = (time1, time2) + , certPubKey = pubKey + , certExtensions = + Extensions $ + Just + [ extensionEncode True $ + ExtKeyUsage [KeyUsage_digitalSignature, KeyUsage_keyEncipherment] + ] + } + where + time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) + time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) + simpleDN = DistinguishedName [] + +simpleX509 :: PubKey -> SignedCertificate +simpleX509 pubKey = + let cert = simpleCertificate pubKey + sig = replicate 40 1 + sigalg = getSignatureALG pubKey + (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert + in signedExact + +arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate +arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage + +arbitraryX509WithKeyAndUsage + :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate +arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do + cert <- arbitraryCertificate usageFlags pubKey + sig <- resize 40 $ listOf1 arbitrary + let sigalg = getSignatureALG pubKey + let (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert + return signedExact + +arbitraryX509 :: Gen SignedCertificate +arbitraryX509 = do + let (pubKey, privKey) = getGlobalRSAPair + arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) + +instance {-# OVERLAPS #-} Arbitrary [ExtKeyUsageFlag] where + arbitrary = sublistOf knownKeyUsage + +knownKeyUsage :: [ExtKeyUsageFlag] +knownKeyUsage = + [ KeyUsage_digitalSignature + , KeyUsage_keyEncipherment + , KeyUsage_keyAgreement + ] + +getSignatureALG :: PubKey -> SignatureALG +getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA +getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA +getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC +getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 +getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 +getSignatureALG pubKey = + error $ "getSignatureALG: unsupported public key: " ++ show pubKey + +toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey +toPubKeyEC curveName key = + let (x, y) = fromPoint $ ECDSA.public_q key + pub = SerializedPoint bs + bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) + bits = ECC.curveSizeBits (ECC.getCurveByName curveName) + bytes = (bits + 7) `div` 8 + in PubKeyEC (PubKeyEC_Named curveName pub) + +toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey +toPrivKeyEC curveName key = + let priv = ECDSA.private_d key + in PrivKeyEC (PrivKeyEC_Named curveName priv) + +fromPoint :: ECC.Point -> (Integer, Integer) +fromPoint (ECC.Point x y) = (x, y) +fromPoint _ = error "fromPoint" diff --git a/test/CiphersSpec.hs b/test/CiphersSpec.hs new file mode 100644 --- /dev/null +++ b/test/CiphersSpec.hs @@ -0,0 +1,74 @@ +module CiphersSpec where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Network.TLS.Cipher +import Network.TLS.Extra.Cipher +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +spec :: Spec +spec = do + describe "ciphers" $ do + prop "can ecnrypt/decrypt" $ \(BulkTest bulk key iv t additional) -> do + let enc = bulkInit bulk BulkEncrypt key + dec = bulkInit bulk BulkDecrypt key + case (enc, dec) of + (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF iv t + (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF iv t additional + (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF t + _ -> return () + +block + :: BulkBlock + -> BulkBlock + -> BulkIV + -> ByteString + -> IO () +block e d iv t = do + let (etxt, e_iv) = e iv t + (dtxt, d_iv) = d iv etxt + dtxt `shouldBe` t + d_iv `shouldBe` e_iv + +stream + :: (ByteString -> (ByteString, BulkStream)) + -> (ByteString -> (ByteString, BulkStream)) + -> ByteString + -> Expectation +stream e d t = (fst . d . fst . e) t `shouldBe` t + +aead + :: BulkAEAD + -> BulkAEAD + -> BulkNonce + -> ByteString + -> BulkAdditionalData + -> Expectation +aead e d iv t additional = do + let (encrypted, at) = e iv t additional + (decrypted, at2) = d iv encrypted additional + decrypted `shouldBe` t + at `shouldBe` at2 + +arbitraryKey :: Bulk -> Gen B.ByteString +arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) + +arbitraryIV :: Bulk -> Gen B.ByteString +arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) + +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 + deriving (Show, Eq) + +instance Arbitrary BulkTest where + arbitrary = do + bulk <- cipherBulk `fmap` elements ciphersuite_all + BulkTest bulk + <$> arbitraryKey bulk + <*> arbitraryIV bulk + <*> arbitraryText bulk + <*> arbitraryText bulk diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/EncodeSpec.hs @@ -0,0 +1,39 @@ +module EncodeSpec where + +import Data.ByteString (ByteString) +import Network.TLS +import Network.TLS.Internal +import Test.Hspec +import Test.Hspec.QuickCheck + +import Arbitrary () + +spec :: Spec +spec = do + describe "encoder/decoder" $ do + prop "can encode/decode Header" $ \x -> do + decodeHeader (encodeHeader x) `shouldBe` Right x + prop "can encode/decode Handshake" $ \x -> do + decodeHs (encodeHandshake x) `shouldBe` Right x + prop "can encode/decode Handshake13" $ \x -> do + decodeHs13 (encodeHandshake13 x) `shouldBe` Right x + +decodeHs :: ByteString -> Either TLSError Handshake +decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b + where + cp = + CurrentParams + { cParamsVersion = TLS12 + , cParamsKeyXchgType = Just CipherKeyExchange_RSA + } + +decodeHs13 :: ByteString -> Either TLSError Handshake13 +decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b + +verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a +verifyResult fn result = + case result of + GotPartial _ -> error "got partial" + GotError e -> error ("got error: " ++ show e) + GotSuccessRemaining _ _ -> error "got remaining byte left" + GotSuccess (ty, content) -> fn ty content diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HandshakeSpec.hs @@ -0,0 +1,1017 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HandshakeSpec where + +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.Internal +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import API +import Arbitrary +import PipeChan +import Run +import Session + +spec :: Spec +spec = do + describe "pipe" $ do + it "can setup a channel" pipe_work + describe "handshake" $ do + prop "can run TLS 1.2" handshake_simple + prop "can run TLS 1.3" handshake13_simple + prop "can update key for TLS 1.3" handshake_update_key + prop "can prevent downgrade attack" handshake13_downgrade + prop "can negotiate hash and signature" handshake_hashsignatures + prop "can negotiate cipher suite" handshake_ciphersuites + prop "can negotiate group" handshake_groups + prop "can negotiate elliptic curve" handshake_ec + prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher + prop + "can fallback for certificate with hash and signature" + handshake_cert_fallback_hs + prop "can handle server key usage" handshake_server_key_usage + prop "can handle client key usage" handshake_client_key_usage + prop "can authenticate client" handshake_client_auth + prop "can receive client authentication failure" handshake_client_auth_fail + prop "can handle extended main secret" handshake_ems + prop "can resume with extended main secret" handshake_resumption_ems + prop "can handle ALPN" handshake_alpn + prop "can handle SNI" handshake_sni + 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 + 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 EE" handshake13_ee_groups + prop "can handshake with TLS 1.3 EC groups" handshake13_ec + prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe + prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth + +-------------------------------------------------------------- + +pipe_work :: IO () +pipe_work = do + pipe <- newPipe + _ <- runPipe pipe + + let bSize = 16 + n <- generate (choose (1, 32)) + + let d1 = B.replicate (bSize * n) 40 + let d2 = B.replicate (bSize * n) 45 + + d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1) + d1' `shouldBe` d1 + + d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2) + d2' `shouldBe` d2 + +-------------------------------------------------------------- + +handshake_simple :: (ClientParams, ServerParams) -> IO () +handshake_simple = runTLSSimple + +-------------------------------------------------------------- + +newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP13 where + arbitrary = CSP13 <$> arbitraryPairParams13 + +handshake13_simple :: CSP13 -> IO () +handshake13_simple (CSP13 params) = runTLSSimple13 params hs + where + cgrps = supportedGroups $ clientSupported $ fst params + sgrps = supportedGroups $ serverSupported $ snd params + hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest + +-------------------------------------------------------------- + +handshake13_downgrade :: (ClientParams, ServerParams) -> IO () +handshake13_downgrade (cparam, sparam) = do + versionForced <- + generate $ elements (supportedVersions $ clientSupported cparam) + let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} + sparam' = sparam{serverDebug = debug'} + params = (cparam, sparam') + downgraded = + (isVersionEnabled TLS13 params && versionForced < TLS13) + || (isVersionEnabled TLS12 params && versionForced < TLS12) + if downgraded + then runTLSFailure params handshake handshake + else runTLSSimple params + +handshake_update_key :: (ClientParams, ServerParams) -> IO () +handshake_update_key = runTLSSimpleKeyUpdate + +-------------------------------------------------------------- + +handshake_hashsignatures + :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () +handshake_hashsignatures (clientHashSigs, serverHashSigs) = do + 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 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (ciphers, ciphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = clientHashSigs + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = serverHashSigs + } + } + commonHashSigs = clientHashSigs `intersect` serverHashSigs + shouldFail + | tls13 = all incompatibleWithDefaultCurve commonHashSigs + | otherwise = null commonHashSigs + if shouldFail + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSSimple (clientParam', serverParam') + where + incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 + incompatibleWithDefaultCurve _ = False + +handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () +handshake_ciphersuites (clientCiphers, serverCiphers) = do + tls13 <- generate arbitrary + let version = if tls13 then TLS13 else TLS12 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (clientCiphers, serverCiphers) + let adequate = cipherAllowedForVersion version + shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) + if shouldSucceed + then runTLSSimple (clientParam, serverParam) + else runTLSFailure (clientParam, serverParam) handshake handshake + +-------------------------------------------------------------- + +handshake_groups :: GGP -> IO () +handshake_groups (GGP clientGroups serverGroups) = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = ciphersuite_strong + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + denyCustom <- generate arbitrary + let groupUsage = + if denyCustom + then GroupUsageUnsupported "custom group denied" + else GroupUsageValid + clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups + } + , clientHooks = + (clientHooks clientParam) + { onCustomFFDHEGroup = \_ _ -> return groupUsage + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = serverGroups + } + } + commonGroups = clientGroups `intersect` serverGroups + shouldFail = null commonGroups + p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups + if shouldFail + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSPredicate (clientParam', serverParam') p + +-------------------------------------------------------------- + +newtype SG = SG [Group] deriving (Show) + +instance Arbitrary SG where + arbitrary = SG <$> shuffle sigGroups + where + sigGroups = [P256, P521] + +handshake_ec :: SG -> IO () +handshake_ec (SG sigGroups) = do + let versions = [TLS12] + ciphers = + [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 + ] + hashSignatures = + [ (HashSHA256, SignatureECDSA) + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + clientGroups <- generate $ shuffle sigGroups + clientHashSignatures <- generate $ sublistOf hashSignatures + serverHashSignatures <- generate $ sublistOf hashSignatures + credentials <- generate arbitraryCredentialsOfEachCurve + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups + , supportedHashSignatures = clientHashSignatures + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = sigGroups + , supportedHashSignatures = serverHashSignatures + } + , serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials credentials + } + } + sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) + ecdsaDenied = SignatureECDSA `notElem` sigAlgs + if ecdsaDenied + then runTLSFailure (clientParam', serverParam') handshake handshake + else runTLSSimple (clientParam', serverParam') + +-- Tests ability to use or ignore client "signature_algorithms" extension when +-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but +-- the server RSA certificate has a SHA-1 signature that the client does not +-- support. Server may choose the DSA certificate only when cipher +-- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA +-- certificate. + +data OC = OC [Cipher] [Cipher] deriving (Show) + +instance Arbitrary OC where + arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers + where + otherCiphers = + [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128GCM_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] + hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = hashSignatures + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + runTLSSimple (clientParam', serverParam) + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` True + +-- Same as above but testing with supportedHashSignatures directly instead of +-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the +-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by +-- both client and server, the Ed25519 certificate is selected. Otherwise the +-- server fallbacks to RSA. +-- +-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 +-- unless client advertises explicit support. Currently this is not enforced by +-- the library, which is useful to test this scenario. SHA-1 could be replaced +-- by another algorithm. + +data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm] + deriving (Show) + +instance Arbitrary OHS where + arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS + where + otherHS = [(HashIntrinsic, SignatureEd25519)] + +handshake_cert_fallback_hs :: OHS -> IO () +handshake_cert_fallback_hs (OHS clientHS serverHS) = do + 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 + ] + commonHS = + [ (HashSHA256, SignatureRSA) + , (HashIntrinsic, SignatureRSApssRSAeSHA256) + ] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = commonHS ++ clientHS + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = commonHS ++ serverHS + } + } + eddsaDisallowed = + (HashIntrinsic, SignatureEd25519) `notElem` clientHS + || (HashIntrinsic, SignatureEd25519) `notElem` serverHS + runTLSSimple (clientParam', serverParam') + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` eddsaDisallowed + +-------------------------------------------------------------- + +handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_server_key_usage usageFlags = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = ciphersuite_all + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let serverParam' = + serverParam + { serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials [cred] + } + } + shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags + if shouldSucceed + then runTLSSimple (clientParam, serverParam') + else runTLSFailure (clientParam, serverParam') handshake handshake + +handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_client_key_usage usageFlags = do + (clientParam, serverParam) <- generate arbitrary + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags + if shouldSucceed + then runTLSSimple (clientParam', serverParam') + else runTLSFailure (clientParam', serverParam') handshake handshake + +-------------------------------------------------------------- + +handshake_client_auth :: (ClientParams, ServerParams) -> IO () +handshake_client_auth (clientParam, serverParam) = do + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) + cred <- generate (arbitraryClientCredential version) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + runTLSSimple (clientParam', serverParam') + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + +handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () +handshake_client_auth_fail (clientParam, serverParam) = do + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) + cred <- generate (arbitraryClientCredential version) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + runTLSFailure (clientParam', serverParam') handshake handshake + where + validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA) + +-------------------------------------------------------------- + +handshake_ems :: (EMSMode, EMSMode) -> IO () +handshake_ems (cems, sems) = do + params <- generate arbitrary + let params' = setEMSMode (cems, sems) params + version = getConnectVersion params' + emsVersion = version >= TLS10 && version <= TLS12 + use = cems /= NoEMS && sems /= NoEMS + require = cems == RequireEMS || sems == RequireEMS + p info = infoExtendedMainSecret info == (emsVersion && use) + if emsVersion && require && not use + then runTLSFailure params' handshake handshake + else runTLSPredicate params' (maybe False p) + +newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show) + +instance Arbitrary CompatEMS where + arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible) + where + compatible (NoEMS, RequireEMS) = False + compatible (RequireEMS, NoEMS) = False + compatible _ = True + +handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO () +handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + plainParams <- generate arbitrary + let params = + setEMSMode ems $ + setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = + setEMSMode ems2 $ + setPairParamsSessionResuming (fromJust sessionParams) params + + let version = getConnectVersion params2 + emsVersion = version >= TLS10 && version <= TLS12 + + if emsVersion && use ems && not (use ems2) + then runTLSFailure params2 handshake handshake + else do + runTLSSimple params2 + mSessionParams2 <- readClientSessionRef sessionRefs + let sameSession = sessionParams == mSessionParams2 + sameUse = use ems == use ems2 + when emsVersion (sameSession `shouldBe` sameUse) + where + use (NoEMS, _) = False + use (_, NoEMS) = False + use _ = True + +-------------------------------------------------------------- + +handshake_alpn :: (ClientParams, ServerParams) -> IO () +handshake_alpn (clientParam, serverParam) = do + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onSuggestALPN = return $ Just ["h2", "http/1.1"] + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onALPNClientSuggest = Just alpn + } + } + params' = (clientParam', serverParam') + runTLSSuccess params' hsClient hsServer + where + hsClient ctx = do + handshake ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + hsServer ctx = do + handshake ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + alpn xs + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" + +handshake_sni :: (ClientParams, ServerParams) -> IO () +handshake_sni (clientParam, serverParam) = do + ref <- newIORef Nothing + let clientParam' = + clientParam + { clientServerIdentification = (serverName, "") + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onServerNameIndication = onSNI ref + } + } + params' = (clientParam', serverParam') + runTLSSuccess params' hsClient hsServer + receivedName <- readIORef ref + receivedName `shouldBe` Just (Just serverName) + where + hsClient ctx = do + handshake ctx + msni <- getClientSNI ctx + expectMaybe "C: SNI should be Just" serverName msni + hsServer ctx = do + handshake ctx + msni <- getClientSNI ctx + expectMaybe "S: SNI should be Just" serverName msni + onSNI ref name = do + mx <- readIORef ref + mx `shouldBe` Nothing + writeIORef ref (Just name) + return (Credentials []) + serverName = "haskell.org" + +-------------------------------------------------------------- + +newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP12 where + arbitrary = CSP12 <$> arbitraryPairParams12 + +handshake12_renegotiation :: CSP12 -> IO () +handshake12_renegotiation (CSP12 (cparams, sparams)) = do + renegDisabled <- generate arbitrary + let sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedClientInitiatedRenegotiation = not renegDisabled + } + } + if renegDisabled + then runTLSFailure (cparams, sparams') hsClient hsServer + else runTLSSimple (cparams, sparams') + where + hsClient ctx = handshake ctx >> handshake ctx + -- recvData receives the alert from the second handshake + hsServer ctx = handshake ctx >> void (recvData ctx) + +handshake12_session_resumption :: CSP12 -> IO () +handshake12_session_resumption (CSP12 plainParams) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPredicate params2 (maybe False infoTLS12Resumption) + +handshake12_session_ticket :: CSP12 -> IO () +handshake12_session_ticket (CSP12 plainParams) = do + sessionRefs <- twoSessionRefs + let sessionManagers0 = twoSessionManagers sessionRefs + sessionManagers = (fst sessionManagers0, oneSessionTicket) + + let params = setPairParamsSessionManagers sessionManagers plainParams + + runTLSSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPredicate params2 (maybe False infoTLS12Resumption) + +-------------------------------------------------------------- + +handshake13_full :: CSP13 -> IO () +handshake13_full (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +handshake13_hrr :: CSP13 -> IO () +handshake13_hrr (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params HelloRetryRequest + +handshake13_psk :: CSP13 -> IO () +handshake13_psk (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSSimple13 params2 PreSharedKey + +handshake13_psk_ticket :: CSP13 -> IO () +handshake13_psk_ticket (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers0 = twoSessionManagers sessionRefs + sessionManagers = (fst sessionManagers0, oneSessionTicket) + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 params HelloRetryRequest + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSSimple13 params2 PreSharedKey + +handshake13_psk_fallback :: CSP13 -> IO () +handshake13_psk_fallback (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = + [ cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES128CCM_SHA256 + ] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 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' = + def + { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] + , supportedGroups = [P256] + } + + runTLSSimple13 (cli2, srv2') HelloRetryRequest + +handshake13_0rtt :: CSP13 -> IO () +handshake13_0rtt (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + cliHooks = + def + { onSuggestALPN = return $ Just ["h2"] + } + svrHooks = + def + { onALPNClientSuggest = Just (return . head) + } + params0 = + ( cli + { clientSupported = cliSupported + , clientHooks = cliHooks + } + , srv + { serverSupported = svrSupported + , serverHooks = svrHooks + , serverEarlyDataSize = 2048 + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSSimple13 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) + + runTLS0RTT params2 RTT0 earlyData + +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] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [group0] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverEarlyDataSize = maxEarlyDataSize + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + let mode = if group0 == P256 then FullHandshake else HelloRetryRequest + runTLSSimple13 params 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 params + svrSupported1 = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [group1] + } + params1 = + ( pc{clientUseEarlyData = True} + , ps + { serverEarlyDataSize = 0 + , serverSupported = svrSupported1 + } + ) + + if group1 == group0 + then runTLS0RTT params1 PreSharedKey earlyData + 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_ee_groups :: CSP13 -> IO () +handshake13_ee_groups (CSP13 (cli, srv)) = do + let -- The client prefers P256 + cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} + -- The server prefers X25519 + svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]} + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + (_, serverMessages) <- runTLSCapture13 params + -- The server should tell X25519 in supported_groups in EE to clinet + let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups + eeMessagesHaveExt = + [ any isSupportedGroups exts + | EncryptedExtensions13 exts <- serverMessages + ] + eeMessagesHaveExt `shouldBe` [True] + +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} + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 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} + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +post_handshake_auth :: CSP13 -> IO () +post_handshake_auth (CSP13 (clientParam, serverParam)) = do + cred <- generate (arbitraryClientCredential TLS13) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + if isCredentialDSA cred + then runTLSFailure (clientParam', serverParam') hsClient hsServer + else runTLSSuccess (clientParam', serverParam') hsClient hsServer + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + hsClient ctx = do + handshake ctx + sendData ctx "request 1" + recvDataAssert ctx "response 1" + sendData ctx "request 2" + recvDataAssert ctx "response 2" + hsServer ctx = do + handshake ctx + recvDataAssert ctx "request 1" + _ <- requestCertificate ctx -- single request + sendData ctx "response 1" + recvDataAssert ctx "request 2" + _ <- requestCertificate ctx + _ <- requestCertificate ctx -- two simultaneously + sendData ctx "response 2" + +expectJust :: String -> Maybe a -> Expectation +expectJust tag mx = case mx of + Nothing -> expectationFailure tag + Just _ -> return () diff --git a/test/PipeChan.hs b/test/PipeChan.hs new file mode 100644 --- /dev/null +++ b/test/PipeChan.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE RecordWildCards #-} + +-- create a similar concept than a unix pipe. +module PipeChan ( + PipeChan (..), + newPipe, + runPipe, + readPipeC, + readPipeS, + writePipeC, + writePipeS, +) where + +import Control.Concurrent +import Control.Monad (forever) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.IORef + +---------------------------------------------------------------- + +-- | represent a unidirectional pipe with a buffered read channel and +-- a write channel +data UniPipeChan = UniPipeChan + { getReadUniPipe :: Chan ByteString + , getWriteUniPipe :: Chan ByteString + } + +newUniPipeChan :: IO UniPipeChan +newUniPipeChan = UniPipeChan <$> newChan <*> newChan + +runUniPipe :: UniPipeChan -> IO ThreadId +runUniPipe UniPipeChan{..} = + forkIO $ + forever $ + readChan getReadUniPipe >>= writeChan getWriteUniPipe + +---------------------------------------------------------------- + +-- | Represent a bidirectional pipe with 2 nodes A and B +data PipeChan = PipeChan + { fromC :: IORef ByteString + , fromS :: IORef ByteString + , c2s :: UniPipeChan + , s2c :: UniPipeChan + } + +newPipe :: IO PipeChan +newPipe = + PipeChan + <$> newIORef B.empty + <*> newIORef B.empty + <*> newUniPipeChan + <*> newUniPipeChan + +runPipe :: PipeChan -> IO (ThreadId, ThreadId) +runPipe PipeChan{..} = (,) <$> runUniPipe c2s <*> runUniPipe s2c + +readPipeC :: PipeChan -> Int -> IO ByteString +readPipeC PipeChan{..} sz = readBuffered fromS (getWriteUniPipe s2c) sz + +writePipeC :: PipeChan -> ByteString -> IO () +writePipeC PipeChan{..} = writeChan $ getWriteUniPipe c2s + +readPipeS :: PipeChan -> Int -> IO ByteString +readPipeS PipeChan{..} sz = readBuffered fromC (getWriteUniPipe c2s) sz + +writePipeS :: PipeChan -> ByteString -> IO () +writePipeS PipeChan{..} = writeChan $ getReadUniPipe s2c + +-- helper to read buffered data. +readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString +readBuffered ref chan sz = do + left <- readIORef ref + if B.length left >= sz + then do + let (ret, nleft) = B.splitAt sz left + writeIORef ref nleft + return ret + else do + let newSize = sz - B.length left + newData <- readChan chan + writeIORef ref newData + remain <- readBuffered ref chan newSize + return (left `B.append` remain) diff --git a/test/PubKey.hs b/test/PubKey.hs new file mode 100644 --- /dev/null +++ b/test/PubKey.hs @@ -0,0 +1,122 @@ +module PubKey ( + arbitraryRSAPair, + arbitraryDSAPair, + arbitraryECDSAPair, + arbitraryEd25519Pair, + arbitraryEd448Pair, + globalRSAPair, + getGlobalRSAPair, + knownECCurves, + defaultECCurve, + dsaParams, + rsaParams, +) where + +import Control.Concurrent.MVar +import Crypto.Error +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Prim as ECC +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA as RSA +import Crypto.Random +import qualified Data.ByteString as B +import System.IO.Unsafe +import Test.QuickCheck + +arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) +arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary + where + rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey) + rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG + +arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey) +arbitraryRSAPairWithRNG = RSA.generate 256 0x10001 + +{-# NOINLINE globalRSAPair #-} +globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) +globalRSAPair = unsafePerformIO $ do + drg <- drgNew + newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG) + +{-# NOINLINE getGlobalRSAPair #-} +getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) +getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) + +rsaParams :: (RSA.PublicKey, RSA.PrivateKey) +rsaParams = (pub, priv) + where + priv = + RSA.PrivateKey + { RSA.private_pub = pub + , RSA.private_d = d + , RSA.private_p = 0 + , RSA.private_q = 0 + , RSA.private_dP = 0 + , RSA.private_dQ = 0 + , RSA.private_qinv = 0 + } + pub = + RSA.PublicKey + { RSA.public_size = 1024 `div` 8 + , RSA.public_n = n + , RSA.public_e = e + } + n = + 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 + e = 0x10001 + d = + 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 + +dsaParams :: DSA.Params +dsaParams = + DSA.Params + { DSA.params_p = + 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb + , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b + , DSA.params_g = + 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff + } + +arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) +arbitraryDSAPair = do + priv <- choose (1, DSA.params_q dsaParams) + let pub = DSA.calculatePublic dsaParams priv + return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) + +-- for performance reason P521 is not tested +knownECCurves :: [ECC.CurveName] +knownECCurves = + [ ECC.SEC_p256r1 + , ECC.SEC_p384r1 + ] + +defaultECCurve :: ECC.CurveName +defaultECCurve = ECC.SEC_p256r1 + +arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey) +arbitraryECDSAPair curveName = do + d <- choose (1, n - 1) + let p = ECC.pointBaseMul curve d + return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d) + where + curve = ECC.getCurveByName curveName + n = ECC.ecc_n . ECC.common_curve $ curve + +arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) +arbitraryEd25519Pair = do + bytes <- vectorOf 32 arbitrary + let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes) + return (Ed25519.toPublic priv, priv) + +arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) +arbitraryEd448Pair = do + bytes <- vectorOf 57 arbitrary + let priv = fromCryptoPassed $ Ed448.secretKey (B.pack bytes) + return (Ed448.toPublic priv, priv) + +fromCryptoPassed :: CryptoFailable a -> a +fromCryptoPassed (CryptoPassed x) = x +fromCryptoPassed _ = error "fromCryptoPassed" diff --git a/test/Run.hs b/test/Run.hs new file mode 100644 --- /dev/null +++ b/test/Run.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Run ( + runTLS, + runTLSSimple, + runTLSPredicate, + runTLSSimple13, + runTLS0RTT, + runTLSSimpleKeyUpdate, + runTLSCapture13, + runTLSSuccess, + runTLSFailure, + expectMaybe, +) where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad +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 +import Test.Hspec +import Test.QuickCheck + +import API +import Arbitrary +import PipeChan + +type ClinetWithInput = Chan ByteString -> Context -> IO () +type ServerWithOutput = Context -> Chan [ByteString] -> IO () + +---------------------------------------------------------------- + +runTLS + :: (ClientParams, ServerParams) + -> ClinetWithInput + -> ServerWithOutput + -> IO () +runTLS = runTLSN 1 + +runTLSN + :: Int + -> (ClientParams, ServerParams) + -> ClinetWithInput + -> ServerWithOutput + -> IO () +runTLSN n params tlsClient tlsServer = do + inputChan <- newChan + outputChan <- newChan + -- generate some data to send + ds <- replicateM n $ B.pack <$> generate (someWords8 256) + forM_ ds $ writeChan inputChan + -- run client and server + withPairContext params $ \(cCtx, sCtx) -> + concurrently_ (server sCtx outputChan) (client inputChan cCtx) + -- read result + mDs <- timeout 1000000 $ readChan outputChan -- 60 sec + expectMaybe "timeout" ds mDs + where + server sCtx outputChan = + E.catch + (tlsServer sCtx outputChan) + (printAndRaise "S: " (serverSupported $ snd params)) + client inputChan cCtx = + E.catch + (tlsClient inputChan cCtx) + (printAndRaise "C: " (clientSupported $ fst params)) + printAndRaise :: String -> Supported -> E.SomeException -> IO () + printAndRaise s supported e = do + putStrLn $ + s + ++ " exception: " + ++ show e + ++ ", supported: " + ++ show supported + E.throwIO e + +---------------------------------------------------------------- + +runTLSSimple :: (ClientParams, ServerParams) -> IO () +runTLSSimple params = runTLSPredicate params (const True) + +runTLSPredicate + :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> IO () +runTLSPredicate params p = runTLSSuccess params hsClient hsServer + where + hsClient ctx = do + handshake ctx + checkInfoPredicate ctx + hsServer ctx = do + handshake ctx + checkInfoPredicate ctx + checkInfoPredicate ctx = do + minfo <- contextGetInformation ctx + unless (p minfo) $ + fail ("unexpected information: " ++ show minfo) + +---------------------------------------------------------------- + +runTLSSimple13 + :: (ClientParams, ServerParams) + -> HandshakeMode13 + -> IO () +runTLSSimple13 params mode = + runTLSSuccess params hsClient hsServer + where + hsClient ctx = do + handshake ctx + mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx + expectMaybe "C: mode should be Just" mode mmode + hsServer ctx = do + handshake ctx + mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx + expectMaybe "S: mode should be Just" mode mmode + +runTLS0RTT + :: (ClientParams, ServerParams) + -> HandshakeMode13 + -> ByteString + -> IO () +runTLS0RTT 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 + mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx + expectMaybe "C: mode should be Just" mode mmode + 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 + +runTLSCapture13 + :: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13]) +runTLSCapture13 params = do + sRef <- newIORef [] + cRef <- newIORef [] + runTLSSuccess 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 + hsServer ref ctx = do + installHook ctx ref + handshake ctx + installHook ctx ref = + let recv hss = modifyIORef ref (hss :) >> return hss + in contextHookSetHandshake13Recv ctx recv + +runTLSSimpleKeyUpdate :: (ClientParams, ServerParams) -> IO () +runTLSSimpleKeyUpdate params = runTLSN 3 params tlsClient tlsServer + where + tlsClient queue ctx = do + handshake ctx + d0 <- readChan queue + sendData ctx (L.fromChunks [d0]) + d1 <- readChan queue + sendData ctx (L.fromChunks [d1]) + req <- generate $ elements [OneWay, TwoWay] + _ <- updateKey ctx req + d2 <- readChan queue + sendData ctx (L.fromChunks [d2]) + checkCtxFinished ctx + bye ctx + tlsServer ctx queue = do + handshake ctx + d0 <- recvData ctx + req <- generate $ elements [OneWay, TwoWay] + _ <- updateKey ctx req + d1 <- recvData ctx + d2 <- recvData ctx + writeChan queue [d0, d1, d2] + checkCtxFinished ctx + bye ctx + +---------------------------------------------------------------- + +runTLSSuccess + :: (ClientParams, ServerParams) + -> (Context -> IO ()) + -> (Context -> IO ()) + -> IO () +runTLSSuccess params hsClient hsServer = runTLS params tlsClient tlsServer + where + tlsClient queue ctx = do + hsClient ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + checkCtxFinished ctx + bye ctx + tlsServer ctx queue = do + hsServer ctx + d <- recvData ctx + writeChan queue [d] + checkCtxFinished ctx + bye ctx + +runTLSFailure + :: (ClientParams, ServerParams) + -> (Context -> IO c) + -> (Context -> IO s) + -> IO () +runTLSFailure params hsClient hsServer = + withPairContext params $ \(cCtx, sCtx) -> + concurrently_ (tlsServer sCtx) (tlsClient cCtx) + where + tlsClient ctx = hsClient ctx `shouldThrow` anyTLSException + tlsServer ctx = hsServer ctx `shouldThrow` anyTLSException + +anyTLSException :: Selector TLSException +anyTLSException = const True + +---------------------------------------------------------------- + +debug :: Bool +debug = False + +withPairContext + :: (ClientParams, ServerParams) -> ((Context, Context) -> IO ()) -> IO () +withPairContext params body = + E.bracket + (newPairContext params) + (\((t1, t2), _) -> killThread t1 >> killThread t2) + (\(_, ctxs) -> body ctxs) + +newPairContext + :: (ClientParams, ServerParams) + -> IO ((ThreadId, ThreadId), (Context, Context)) +newPairContext (cParams, sParams) = do + pipe <- newPipe + tids <- runPipe pipe + let noFlush = return () + let noClose = return () + + let cBackend = Backend noFlush noClose (writePipeC pipe) (readPipeC pipe) + let sBackend = Backend noFlush noClose (writePipeS pipe) (readPipeS pipe) + cCtx' <- contextNew cBackend cParams + sCtx' <- contextNew sBackend sParams + + contextHookSetLogging cCtx' (logging "client: ") + contextHookSetLogging sCtx' (logging "server: ") + + return (tids, (cCtx', sCtx')) + where + logging pre = + if debug + then + def + { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) + , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) + } + else def diff --git a/test/Session.hs b/test/Session.hs new file mode 100644 --- /dev/null +++ b/test/Session.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Session ( + readClientSessionRef, + clearClientSessionRef, + twoSessionRefs, + twoSessionManagers, + setPairParamsSessionManagers, + setPairParamsSessionResuming, + oneSessionTicket, +) where + +import Codec.Serialise +import Control.Monad +import qualified Data.ByteString.Lazy as L +import Data.IORef +import Network.TLS +import Network.TLS.Internal + +---------------------------------------------------------------- + +readClientSessionRef :: (IORef (Maybe c), IORef (Maybe s)) -> IO (Maybe c) +readClientSessionRef refs = readIORef (fst refs) + +clearClientSessionRef :: (IORef (Maybe c), IORef (Maybe s)) -> IO () +clearClientSessionRef refs = writeIORef (fst refs) Nothing + +twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server)) +twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing + +-- | simple session manager to store one session id and session data for a single thread. +-- a Real concurrent session manager would use an MVar and have multiples items. +oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +oneSessionManager ref = + SessionManager + { sessionResume = \myId -> readIORef ref >>= maybeResume False myId + , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId + , sessionEstablish = \myId dat -> writeIORef ref (Just (myId, dat)) >> return Nothing + , sessionInvalidate = \_ -> return () + , sessionUseTicket = False + } + where + maybeResume onlyOnce myId (Just (sid, sdata)) + | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata) + maybeResume _ _ _ = return Nothing + +twoSessionManagers + :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) + -> (SessionManager, SessionManager) +twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) + +setPairParamsSessionManagers + :: (SessionManager, SessionManager) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setPairParamsSessionManagers (clientManager, serverManager) (clientParams, serverParams) = (nc, ns) + where + nc = + clientParams + { clientShared = updateSessionManager clientManager $ clientShared clientParams + } + ns = + serverParams + { serverShared = updateSessionManager serverManager $ serverShared serverParams + } + updateSessionManager manager shared = shared{sharedSessionManager = manager} + +---------------------------------------------------------------- + +setPairParamsSessionResuming + :: (SessionID, SessionData) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setPairParamsSessionResuming sessionStuff (clientParams, serverParams) = + ( clientParams{clientWantSessionResume = Just sessionStuff} + , serverParams + ) + +oneSessionTicket :: SessionManager +oneSessionTicket = + SessionManager + { sessionResume = resume + , sessionResumeOnlyOnce = resume + , sessionEstablish = \_ dat -> return $ Just $ L.toStrict $ serialise dat + , sessionInvalidate = \_ -> return () + , sessionUseTicket = True + } + +resume :: Ticket -> IO (Maybe SessionData) +resume ticket + | isTicket ticket = return $ Just $ deserialise $ L.fromStrict ticket + | otherwise = return Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/ThreadSpec.hs b/test/ThreadSpec.hs new file mode 100644 --- /dev/null +++ b/test/ThreadSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ThreadSpec where + +import Control.Concurrent +import Control.Concurrent.Async +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Foldable (traverse_) +import Network.TLS +import Test.Hspec +import Test.Hspec.QuickCheck + +import API +import Arbitrary () +import Run + +spec :: Spec +spec = do + describe "thread safety" $ do + prop "can read/write concurrently" $ \params -> + runTLS params tlsClient tlsServer + +tlsClient :: Chan ByteString -> Context -> IO () +tlsClient queue ctx = do + handshake ctx + runReaderWriters ctx "server-value" "client-value" + d <- readChan queue + sendData ctx (L.fromChunks [d]) + checkCtxFinished ctx + bye ctx + +tlsServer :: Context -> Chan [ByteString] -> IO () +tlsServer ctx queue = do + handshake ctx + runReaderWriters ctx "client-value" "server-value" + d <- recvData ctx + writeChan queue [d] + checkCtxFinished ctx + bye ctx + +runReaderWriters :: Context -> ByteString -> L.ByteString -> IO () +runReaderWriters ctx r w = + -- run concurrently 10 readers and 10 writers on the same context + let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] + in runConcurrently $ traverse_ Concurrently workers diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,32 +1,20 @@ cabal-version: >=1.10 name: tls -version: 1.9.0 +version: 2.0.0 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez maintainer: Kazu Yamamoto author: Vincent Hanquez -stability: experimental homepage: https://github.com/haskell-tls/hs-tls -synopsis: TLS/SSL protocol native implementation (Server and Client) +synopsis: TLS protocol native implementation description: - Native Haskell TLS and SSL protocol implementation for server and client. - . - This provides a high-level implementation of a sensitive security protocol, - eliminating a common set of security issues through the use of the advanced - type system, high level constructions and common Haskell features. - . - Currently implement the TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol, - and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges, - and many extensions. - . - Some debug tools linked with tls, are available through the - . + Native Haskell TLS 1.2/1.3 protocol implementation for servers and clients. category: Network build-type: Simple extra-source-files: - Tests/*.hs + test/*.hs CHANGELOG.md source-repository head @@ -34,15 +22,8 @@ location: https://github.com/haskell-tls/hs-tls subdir: core -flag compat - description: - Accept SSLv2 client hello for beginning SSLv3 / TLS handshake - -flag network - description: Use the base network library - -flag hans - description: Use the Haskell Network Stack (HaNS) +flag devel + description: Development commands default: False library @@ -57,7 +38,6 @@ Network.TLS.QUIC other-modules: - Network.TLS.Cap Network.TLS.Struct Network.TLS.Struct13 Network.TLS.Core @@ -74,6 +54,11 @@ Network.TLS.Handshake Network.TLS.Handshake.Certificate Network.TLS.Handshake.Client + Network.TLS.Handshake.Client.ClientHello + Network.TLS.Handshake.Client.Common + Network.TLS.Handshake.Client.ServerHello + Network.TLS.Handshake.Client.TLS12 + Network.TLS.Handshake.Client.TLS13 Network.TLS.Handshake.Common Network.TLS.Handshake.Common13 Network.TLS.Handshake.Control @@ -81,6 +66,14 @@ Network.TLS.Handshake.Process Network.TLS.Handshake.Random Network.TLS.Handshake.Server + Network.TLS.Handshake.Server.ClientHello + Network.TLS.Handshake.Server.ClientHello12 + Network.TLS.Handshake.Server.ClientHello13 + Network.TLS.Handshake.Server.Common + Network.TLS.Handshake.Server.ServerHello12 + Network.TLS.Handshake.Server.ServerHello13 + Network.TLS.Handshake.Server.TLS12 + Network.TLS.Handshake.Server.TLS13 Network.TLS.Handshake.Signature Network.TLS.Handshake.State Network.TLS.Handshake.State13 @@ -114,89 +107,114 @@ Network.TLS.Wire Network.TLS.X509 + default-extensions: Strict StrictData default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.9 && <5, - mtl >=2.2.1, - transformers, - cereal >=0.5.3, - bytestring, - data-default-class, - memory >=0.14.6, - crypton, - asn1-types >=0.2.0, - asn1-encoding, - crypton-x509 >=1.7.5, - crypton-x509-store >=1.6, - crypton-x509-validation >=1.6.5, - async >=2.0, - unix-time - - if flag(network) - cpp-options: -DINCLUDE_NETWORK - build-depends: network >=2.4.0.0 - - if flag(hans) - cpp-options: -DINCLUDE_HANS - build-depends: hans - - if flag(compat) - cpp-options: -DSSLV2_COMPATIBLE + asn1-encoding >= 0.9 && < 0.10, + asn1-types >= 0.3 && < 0.4, + async >= 2.2 && < 2.3, + base16-bytestring, + bytestring >= 0.10 && < 0.12, + 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 && < 3.2, + serialise >= 0.2 && < 0.3, + transformers >= 0.5 && < 0.7, + unix-time >= 0.4.11 && < 0.5 -test-suite test-tls - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: Tests +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 - Ciphers - Connection - Marshalling + CiphersSpec + EncodeSpec + HandshakeSpec PipeChan PubKey + Run + Session + ThreadSpec - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-imports + default-extensions: Strict StrictData + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts build-depends: - base >=3 && <5, - async >=2.0, - data-default-class, - tasty, - tasty-quickcheck, - tls, + base >=4.9 && <5, QuickCheck, - crypton, - bytestring, asn1-types, + async, + bytestring, + crypton, crypton-x509, crypton-x509-validation, - hourglass + data-default-class, + hourglass, + hspec, + serialise, + tls -benchmark bench-tls - type: exitcode-stdio-1.0 - main-is: Benchmarks.hs - hs-source-dirs: Benchmarks Tests +executable server + main-is: server.hs + hs-source-dirs: util other-modules: - Certificate - Connection - PipeChan - PubKey + Common + HexDump + Imports - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-imports + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts build-depends: - base >=4 && <5, - tls, - crypton-x509, - crypton-x509-validation, - data-default-class, + base >=4.9 && <5, + bytestring, + containers, crypton, - gauge, + crypton-x509-store, + crypton-x509-system, + data-default-class, + network, + tls + + if flag(devel) + + else + buildable: False + +executable client + main-is: client.hs + hs-source-dirs: util + other-modules: + Common + HexDump + Imports + + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts + build-depends: + base >=4.9 && <5, bytestring, - asn1-types, - async >=2.0, - hourglass, - QuickCheck >=2, - tasty-quickcheck, + crypton, + crypton-x509-store, + crypton-x509-system, + data-default-class, + network, tls + + if flag(devel) + + else + buildable: False diff --git a/util/Common.hs b/util/Common.hs new file mode 100644 --- /dev/null +++ b/util/Common.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE CPP #-} +-- Disable this warning so we can still test deprecated functionality. +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +module Common ( + printCiphers, + printDHParams, + printGroups, + readNumber, + readCiphers, + readDHParams, + readGroups, + printHandshakeInfo, + makeAddrInfo, + AddrInfo (..), + getCertificateStore, +) where + +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 Imports + +namedDHParams :: [(String, DHParams)] +namedDHParams = + [ ("ffdhe2048", ffdhe2048) + , ("ffdhe3072", ffdhe3072) + , ("ffdhe4096", ffdhe4096) + , ("ffdhe6144", ffdhe6144) + , ("ffdhe8192", ffdhe8192) + ] + +namedCiphersuites :: [(String, [CipherID])] +namedCiphersuites = + [ ("all", map cipherID ciphersuite_all) + , ("default", map cipherID ciphersuite_default) + , ("strong", map cipherID ciphersuite_strong) + ] + +namedGroups :: [(String, Group)] +namedGroups = + [ ("ffdhe2048", FFDHE2048) + , ("ffdhe3072", FFDHE3072) + , ("ffdhe4096", FFDHE4096) + , ("ffdhe6144", FFDHE6144) + , ("ffdhe8192", FFDHE8192) + , ("p256", P256) + , ("p384", P384) + , ("p521", P521) + , ("x25519", X25519) + , ("x448", X448) + ] + +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) + +printDHParams :: IO () +printDHParams = do + putStrLn "DH Parameters" + putStrLn "=====================================" + forM_ namedDHParams $ \(name, _) -> putStrLn name + putStrLn "(or /path/to/dhparams)" + +printGroups :: IO () +printGroups = do + putStrLn "Groups" + 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) + (s', "") -> [s'] + (s', r) -> s' : split c (tail r) + +getCertificateStore :: [FilePath] -> IO CertificateStore +getCertificateStore [] = getSystemCertificateStore +getCertificateStore paths = foldM readPathAppend mempty paths + where + readPathAppend acc path = do + mstore <- readCertificateStore path + case mstore of + Nothing -> error ("invalid certificate store: " ++ path) + Just st -> return $! mappend st acc diff --git a/util/HexDump.hs b/util/HexDump.hs new file mode 100644 --- /dev/null +++ b/util/HexDump.hs @@ -0,0 +1,96 @@ +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 diff --git a/util/Imports.hs b/util/Imports.hs new file mode 100644 --- /dev/null +++ b/util/Imports.hs @@ -0,0 +1,17 @@ +module Imports ( + ByteString, + module Control.Applicative, + module Control.Monad, + module Data.List, + module Data.Maybe, + module Data.Monoid, + module Data.Word, +) where + +import Control.Applicative +import Control.Monad +import Data.ByteString (ByteString) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Word diff --git a/util/client.hs b/util/client.hs new file mode 100644 --- /dev/null +++ b/util/client.hs @@ -0,0 +1,515 @@ +{-# 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] [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 diff --git a/util/server.hs b/util/server.hs new file mode 100644 --- /dev/null +++ b/util/server.hs @@ -0,0 +1,492 @@ +{-# 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 + }