From 5bada58646a4f44feb93960907022bb47e9e4b51 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 23 Oct 2023 17:58:56 +0900 Subject: [PATCH 01/10] removing Cabal flags --- core/Network/TLS.hs | 3 -- core/Network/TLS/Backend.hs | 45 +----------------------------- core/Network/TLS/Context.hs | 7 ----- core/Network/TLS/Record/Reading.hs | 21 -------------- core/Network/TLS/Types.hs | 7 ----- core/tls.cabal | 39 ++++++-------------------- 6 files changed, 10 insertions(+), 112 deletions(-) diff --git a/core/Network/TLS.hs b/core/Network/TLS.hs index 083ef644d..0e30cf3a5 100644 --- a/core/Network/TLS.hs +++ b/core/Network/TLS.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS -- License : BSD-style @@ -156,9 +155,7 @@ module Network.TLS -- * Deprecated , recvData' , contextNewOnHandle -#ifdef INCLUDE_NETWORK , contextNewOnSocket -#endif , Bytes , ValidationChecks(..) , ValidationHooks(..) diff --git a/core/Network/TLS/Backend.hs b/core/Network/TLS/Backend.hs index db0e4d0bc..bc6e7348e 100644 --- a/core/Network/TLS/Backend.hs +++ b/core/Network/TLS/Backend.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Backend -- License : BSD-style @@ -24,16 +23,8 @@ module Network.TLS.Backend 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 -- | Connection IO backend data Backend = Backend @@ -51,24 +42,9 @@ instance HasBackend Backend where 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 @@ -79,25 +55,6 @@ instance HasBackend Network.Socket where 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 instance HasBackend Handle where initializeBackend handle = hSetBuffering handle NoBuffering diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index 2e7f6fa9a..dc079eb32 100644 --- a/core/Network/TLS/Context.hs +++ b/core/Network/TLS/Context.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Context -- License : BSD-style @@ -43,9 +42,7 @@ module Network.TLS.Context , contextNew -- * Deprecated new contexts methods , contextNewOnHandle -#ifdef INCLUDE_NETWORK , contextNewOnSocket -#endif -- * Context hooks , contextHookSetHandshakeRecv @@ -90,9 +87,7 @@ 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 @@ -217,7 +212,6 @@ contextNewOnHandle :: (MonadIO m, TLSParams params) 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. @@ -225,7 +219,6 @@ contextNewOnSocket :: (MonadIO m, TLSParams params) -> m Context contextNewOnSocket sock params = contextNew sock params {-# DEPRECATED contextNewOnSocket "use contextNew" #-} -#endif contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = diff --git a/core/Network/TLS/Record/Reading.hs b/core/Network/TLS/Record/Reading.hs index 3c31c1f34..2744e4253 100644 --- a/core/Network/TLS/Record/Reading.hs +++ b/core/Network/TLS/Record/Reading.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Record.Reading -- License : BSD-style @@ -61,9 +60,6 @@ recvRecord :: Context -- ^ TLS context -> 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 @@ -73,23 +69,6 @@ recvRecord ctx compatSSLv2 appDataOverhead | 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) - - 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 recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext)) recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) diff --git a/core/Network/TLS/Types.hs b/core/Network/TLS/Types.hs index efbc1fa02..cb3193460 100644 --- a/core/Network/TLS/Types.hs +++ b/core/Network/TLS/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Types @@ -36,16 +35,10 @@ module Network.TLS.Types , MasterSecret(..) ) where -#ifdef INCLUDE_NETWORK import Network.Socket (HostName) -#endif - import Network.TLS.Imports import Network.TLS.Crypto.Types (Group) -#ifndef INCLUDE_NETWORK -type HostName = String -#endif type Second = Word32 type Millisecond = Word64 diff --git a/core/tls.cabal b/core/tls.cabal index c21a47d33..a44429296 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -34,17 +34,6 @@ source-repository head 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) - default: False - library exposed-modules: Network.TLS @@ -117,33 +106,23 @@ library default-language: Haskell2010 ghc-options: -Wall build-depends: + asn1-encoding, + asn1-types >=0.2.0, + async >=2.0, base >=4.9 && <5, - mtl >=2.2.1, - transformers, - cereal >=0.5.3, bytestring, - data-default-class, - memory >=0.14.6, + cereal >=0.5.3, 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, + data-default-class, + memory >=0.14.6, + mtl >=2.2.1, + network >=2.4.0.0, + transformers, 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 - test-suite test-tls type: exitcode-stdio-1.0 main-is: Tests.hs From c0305a7736fad4462040e7f57552619f07f86508 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 23 Oct 2023 18:00:52 +0900 Subject: [PATCH 02/10] fourmolu --- core/Benchmarks/Benchmarks.hs | 214 +-- core/Network/TLS.hs | 269 ++-- core/Network/TLS/Backend.hs | 41 +- core/Network/TLS/Cap.hs | 11 +- core/Network/TLS/Cipher.hs | 142 +- core/Network/TLS/Compression.hs | 36 +- core/Network/TLS/Context.hs | 293 ++-- core/Network/TLS/Context/Internal.hs | 296 ++-- core/Network/TLS/Core.hs | 371 +++-- core/Network/TLS/Credentials.hs | 173 ++- core/Network/TLS/Crypto.hs | 432 +++--- core/Network/TLS/Crypto/DH.hs | 51 +- core/Network/TLS/Crypto/IES.hs | 177 ++- core/Network/TLS/Crypto/Types.hs | 22 +- core/Network/TLS/ErrT.hs | 15 +- core/Network/TLS/Extension.hs | 581 +++---- core/Network/TLS/Extra.hs | 8 +- core/Network/TLS/Extra/Cipher.hs | 1703 +++++++++++---------- core/Network/TLS/Extra/FFDHE.hs | 60 +- core/Network/TLS/Handshake.hs | 19 +- core/Network/TLS/Handshake/Certificate.hs | 38 +- core/Network/TLS/Handshake/Client.hs | 1376 +++++++++-------- core/Network/TLS/Handshake/Common.hs | 249 +-- core/Network/TLS/Handshake/Common13.hs | 437 +++--- core/Network/TLS/Handshake/Control.hs | 38 +- core/Network/TLS/Handshake/Key.hs | 113 +- core/Network/TLS/Handshake/Process.hs | 116 +- core/Network/TLS/Handshake/Random.hs | 88 +- core/Network/TLS/Handshake/Server.hs | 1460 ++++++++++-------- core/Network/TLS/Handshake/Signature.hs | 352 +++-- core/Network/TLS/Handshake/State.hs | 696 +++++---- core/Network/TLS/Handshake/State13.hs | 144 +- core/Network/TLS/Hooks.hs | 59 +- core/Network/TLS/IO.hs | 135 +- core/Network/TLS/Imports.hs | 50 +- core/Network/TLS/Internal.hs | 30 +- core/Network/TLS/KeySchedule.hs | 33 +- core/Network/TLS/MAC.hs | 78 +- core/Network/TLS/Measurement.hs | 44 +- core/Network/TLS/Packet.hs | 654 ++++---- core/Network/TLS/Packet13.hs | 113 +- core/Network/TLS/Parameters.hs | 1081 ++++++------- core/Network/TLS/PostHandshake.hs | 27 +- core/Network/TLS/QUIC.hs | 240 +-- core/Network/TLS/RNG.hs | 32 +- core/Network/TLS/Receiving.hs | 87 +- core/Network/TLS/Record.hs | 50 +- core/Network/TLS/Record/Disengage.hs | 267 ++-- core/Network/TLS/Record/Engage.hs | 90 +- core/Network/TLS/Record/Layer.hs | 78 +- core/Network/TLS/Record/Reading.hs | 73 +- core/Network/TLS/Record/State.hs | 186 ++- core/Network/TLS/Record/Types.hs | 85 +- core/Network/TLS/Record/Writing.hs | 32 +- core/Network/TLS/Sending.hs | 79 +- core/Network/TLS/Session.hs | 36 +- core/Network/TLS/State.hs | 301 ++-- core/Network/TLS/Struct.hs | 643 ++++---- core/Network/TLS/Struct13.hs | 110 +- core/Network/TLS/Types.hs | 114 +- core/Network/TLS/Util.hs | 120 +- core/Network/TLS/Util/ASN1.hs | 37 +- core/Network/TLS/Util/Serialization.hs | 12 +- core/Network/TLS/Wire.hs | 130 +- core/Network/TLS/X509.hs | 79 +- core/Setup.hs | 1 + core/Tests/Certificate.hs | 132 +- core/Tests/Ciphers.hs | 41 +- core/Tests/Connection.hs | 462 +++--- core/Tests/Marshalling.hs | 193 ++- core/Tests/PipeChan.hs | 38 +- core/Tests/PubKey.hs | 134 +- core/Tests/Tests.hs | 1369 ++++++++++------- 73 files changed, 9658 insertions(+), 7918 deletions(-) diff --git a/core/Benchmarks/Benchmarks.hs b/core/Benchmarks/Benchmarks.hs index d43975d56..721022c85 100644 --- a/core/Benchmarks/Benchmarks.hs +++ b/core/Benchmarks/Benchmarks.hs @@ -1,88 +1,108 @@ {-# LANGUAGE BangPatterns #-} + module Main where -import Connection import Certificate -import PubKey -import Gauge.Main +import Connection 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 Data.X509 +import Data.X509.Validation +import Gauge.Main +import Network.TLS +import Network.TLS.Extra.Cipher +import PubKey import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L blockCipher :: Cipher -blockCipher = Cipher - { cipherID = 0xff12 - , cipherName = "rsa-id-const" - , cipherBulk = Bulk - { bulkName = "id" - , bulkKeySize = 16 - , bulkIVSize = 16 - , bulkExplicitIV= 0 - , bulkAuthTagLen= 0 - , bulkBlockSize = 16 - , bulkF = BulkBlockF $ \ _ _ _ m -> (m, B.empty) +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 } - , 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) + 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 - } - } + , clientShared = + def + { sharedValidationCache = + ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } } - supported = def { supportedCiphers = [cipher] - , supportedVersions = [connectVer] - , supportedGroups = [X25519, FFDHE2048] - } - (pubKey, privKey) = getGlobalRSAPair + 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 + :: (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 + :: (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 + 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 + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d -benchResumption :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchResumption + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption params !d name = env initializeSession runResumption where initializeSession = do @@ -99,7 +119,8 @@ benchResumption params !d name = env initializeSession runResumption params2 <- readIORef paramsRef runTLSPipeSimple params2 d -benchResumption13 :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark +benchResumption13 + :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchResumption13 params !d name = env initializeSession runResumption where initializeSession = do @@ -124,41 +145,50 @@ benchCiphers name connectVer d = bgroup name . map doBench 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 +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/core/Network/TLS.hs b/core/Network/TLS.hs index 0e30cf3a5..e66c0d0b9 100644 --- a/core/Network/TLS.hs +++ b/core/Network/TLS.hs @@ -19,173 +19,203 @@ -- -- 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, + 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, + HashAlgorithm (..), + SignatureAlgorithm (..), + Group (..), + 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 + ctxConnection, + 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, + 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 - , contextNewOnSocket - , Bytes - , ValidationChecks(..) - , ValidationHooks(..) - ) where - -import Network.TLS.Backend (Backend(..), HasBackend(..)) + recvData', + contextNewOnHandle, + contextNewOnSocket, + Bytes, + ValidationChecks (..), + ValidationHooks (..), +) where + +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 (..)) +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 (..), + ) +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." #-} @@ -199,9 +229,8 @@ type Bytes = B.ByteString 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/core/Network/TLS/Backend.hs b/core/Network/TLS/Backend.hs index bc6e7348e..99943ad6e 100644 --- a/core/Network/TLS/Backend.hs +++ b/core/Network/TLS/Backend.hs @@ -14,24 +14,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) import qualified Network.Socket as Network import qualified Network.Socket.ByteString as Network +import Network.TLS.Imports +import System.IO (BufferMode (..), Handle, hClose, hFlush, hSetBuffering) -- | 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 @@ -48,13 +51,15 @@ safeRecv = Network.recv 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) + 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/core/Network/TLS/Cap.hs b/core/Network/TLS/Cap.hs index cdd1f7c36..d0b608ca7 100644 --- a/core/Network/TLS/Cap.hs +++ b/core/Network/TLS/Cap.hs @@ -4,16 +4,13 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- - -module Network.TLS.Cap - ( hasHelloExtensions - , hasExplicitBlockIV - ) where +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/core/Network/TLS/Cipher.hs b/core/Network/TLS/Cipher.hs index d55870881..532cfb810 100644 --- a/core/Network/TLS/Cipher.hs +++ b/core/Network/TLS/Cipher.hs @@ -1,38 +1,38 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_HADDOCK hide #-} + -- | -- 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 +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,49 +42,48 @@ type BulkIV = B.ByteString 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) + | BulkAeadF (BulkDirection -> BulkKey -> BulkAEAD) -hasMAC,hasRecordIV :: BulkFunctions -> Bool - -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 @@ -95,48 +94,51 @@ data CipherKeyExchangeType = | 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/core/Network/TLS/Compression.hs b/core/Network/TLS/Compression.hs index 361f4b7a3..6845a1552 100644 --- a/core/Network/TLS/Compression.hs +++ b/core/Network/TLS/Compression.hs @@ -1,40 +1,40 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_HADDOCK hide #-} + -- | -- Module : Network.TLS.Compression -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Compression - ( CompressionC(..) - , Compression(..) - , CompressionID - , nullCompression - , NullCompression +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 +65,7 @@ compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l data NullCompression = NullCompression instance CompressionC NullCompression where - compressionCID _ = 0 + compressionCID _ = 0 compressionCDeflate s b = (s, b) compressionCInflate s b = (s, b) diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index dc079eb32..b6e04e134 100644 --- a/core/Network/TLS/Context.hs +++ b/core/Network/TLS/Context.hs @@ -4,83 +4,91 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Context - ( +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 (..), + ctxEOF, + ctxHasSSLv2ClientHello, + ctxDisableSSLv2ClientHello, + ctxEstablished, + withLog, + ctxWithHooks, + contextModifyHooks, + setEOF, + setEstablished, + contextFlush, + contextClose, + contextSend, + contextRecv, + updateMeasure, + withMeasure, + withReadLock, + withWriteLock, + withStateLock, + withRWLock, -- * information - , Information(..) - , contextGetInformation + Information (..), + contextGetInformation, -- * New contexts - , contextNew + contextNew, + -- * Deprecated new contexts methods - , contextNewOnHandle - , contextNewOnSocket + contextNewOnHandle, + contextNewOnSocket, -- * 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_, + runTxState, + runRxState, + usingHState, + getHState, + getStateRNG, + tls13orLater, + getFinished, + getPeerFinished, +) where import Network.TLS.Backend import Network.TLS.Context.Internal -import Network.TLS.Struct -import Network.TLS.Struct13 -import Network.TLS.State +import Network.TLS.Handshake ( + handshakeClient, + handshakeClientWith, + handshakeServer, + handshakeServerWith, + ) import Network.TLS.Hooks -import Network.TLS.Record.State +import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.PostHandshake ( + postHandshakeAuthClientWith, + postHandshakeAuthServerWith, + requestCertificateServer, + ) +import Network.TLS.RNG import Network.TLS.Record.Layer 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 @@ -92,17 +100,18 @@ 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 @@ -110,10 +119,11 @@ instance TLSParams ClientParams where 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 @@ -121,27 +131,31 @@ instance TLSParams ServerParams where 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 + eof <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement -- we enable the reception of SSLv2 ClientHello message only in the @@ -149,92 +163,101 @@ contextNew backend params = liftIO $ do sslv2Compat <- newIORef (role == ServerRole) needEmptyPacket <- newIORef False hooks <- newIORef defaultHooks - tx <- newMVar newRecordState - rx <- newMVar newRecordState - hs <- newMVar Nothing - as <- newIORef [] - crs <- newIORef [] + tx <- newMVar newRecordState + rx <- newMVar newRecordState + hs <- newMVar Nothing + as <- newIORef [] + crs <- newIORef [] lockWrite <- newMVar () - lockRead <- newMVar () + lockRead <- newMVar () lockState <- newMVar () finished <- newIORef Nothing peerFinished <- newIORef Nothing - 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 + { 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 + } syncNoOp _ _ = return () - recordLayer = RecordLayer - { recordEncode = encodeRecord ctx - , recordEncode13 = encodeRecord13 ctx - , recordSendBytes = sendBytes ctx - , recordRecv = recvRecord ctx - , recordRecv13 = recvRecord13 ctx - } + recordLayer = + RecordLayer + { recordEncode = encodeRecord ctx + , recordEncode13 = encodeRecord13 ctx + , recordSendBytes = sendBytes ctx + , recordRecv = recvRecord ctx + , recordRecv13 = recvRecord13 ctx + } 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 + :: (MonadIO m, TLSParams params) + => Handle + -- ^ Handle of the connection. + -> params + -- ^ Parameters of the context. + -> m Context contextNewOnHandle = contextNew {-# DEPRECATED contextNewOnHandle "use contextNew" #-} -- | 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 + :: (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" #-} 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) diff --git a/core/Network/TLS/Context/Internal.hs b/core/Network/TLS/Context/Internal.hs index 292c50410..faf4fee62 100644 --- a/core/Network/TLS/Context/Internal.hs +++ b/core/Network/TLS/Context/Internal.hs @@ -1,74 +1,73 @@ {-# LANGUAGE ExistentialQuantification #-} {-# 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 (..), + PendingAction (..), + ctxEOF, + ctxHasSSLv2ClientHello, + ctxDisableSSLv2ClientHello, + 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_, + runTxState, + runRxState, + usingHState, + getHState, + saveHState, + restoreHState, + getStateRNG, + tls13orLater, + addCertRequest13, + getCertRequest13, + decideRecordVersion, -- * Misc - , HandshakeSync(..) - ) where + HandshakeSync (..), +) where import Network.TLS.Backend import Network.TLS.Cipher @@ -97,72 +96,92 @@ import Data.Tuple -- | Information related to a running context, e.g. current cipher data Information = Information - { infoVersion :: Version - , infoCipher :: Cipher - , infoCompression :: Compression + { infoVersion :: Version + , infoCipher :: Cipher + , infoCompression :: Compression , infoMasterSecret :: Maybe ByteString - , infoExtendedMasterSec :: Bool + , infoExtendedMasterSec :: Bool , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom - , infoNegotiatedGroup :: Maybe Group - , infoTLS13HandshakeMode :: Maybe HandshakeMode13 + , infoNegotiatedGroup :: Maybe Group + , 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 () +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) + , 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 HandshakeSync = HandshakeSync (Context -> ClientState -> IO ()) - (Context -> ServerState -> IO ()) +data HandshakeSync + = HandshakeSync + (Context -> ClientState -> IO ()) + (Context -> ServerState -> IO ()) updateRecordLayer :: Monoid bytes => RecordLayer bytes -> 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 -- remaining 0-RTT bytes allowed + | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip + | 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 + = -- | simple pending action + PendingAction Bool (Handshake13 -> IO ()) + | -- | pending action taking transcript hash up to preceding message + PendingActionHash Bool (ByteString -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) @@ -181,27 +200,31 @@ contextClose = backendClose . ctxConnection -- | 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 -> + ( hstMasterSecret st + , hstExtendedMasterSec st + , Just (hstClientRandom st) + , hstServerRandom st + , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing + , hstNegotiatedGroup st + ) Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing) - (cipher,comp) <- readMVar (ctxRxState ctx) <&> \st -> (stCipher st, stCompression st) + (cipher, comp) <- + readMVar (ctxRxState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of Just st -> hstTLS13RTT0Status st == RTT0Accepted Nothing -> False case (ver, cipher) of (Just v, Just c) -> return $ Just $ Information v c comp ms ems cr sr grp hm13 accepted - _ -> return Nothing + _ -> 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 $ ctxConnection c) b contextRecv :: Context -> Int -> IO ByteString contextRecv c sz = updateMeasure c (addBytesReceived sz) >> (backendRecv $ ctxConnection c) sz @@ -241,13 +264,13 @@ failOnEitherError f = do 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) + 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 @@ -264,9 +287,10 @@ getHState ctx = liftIO $ readMVar (ctxHandshake ctx) saveHState :: Context -> IO (Saved (Maybe HandshakeState)) saveHState ctx = saveMVar (ctxHandshake ctx) -restoreHState :: Context - -> Saved (Maybe HandshakeState) - -> IO (Saved (Maybe HandshakeState)) +restoreHState + :: Context + -> Saved (Maybe HandshakeState) + -> IO (Saved (Maybe HandshakeState)) restoreHState ctx = restoreMVar (ctxHandshake ctx) decideRecordVersion :: Context -> IO (Version, Bool) @@ -277,31 +301,35 @@ decideRecordVersion ctx = usingState_ ctx $ do -- 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 (ver, tls13) <- decideRecordVersion ctx - let opt = RecordOptions { recordVersion = ver - , recordTLS13 = tls13 - } + let opt = + RecordOptions + { recordVersion = ver + , recordTLS13 = tls13 + } modifyMVar (ctxTxState 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 -- For 1.3, ver is just ignored. So, it is not necessary to convert ver. - let opt = RecordOptions { recordVersion = ver - , recordTLS13 = ver >= TLS13 - } + let opt = + RecordOptions + { recordVersion = ver + , recordTLS13 = ver >= TLS13 + } modifyMVar (ctxRxState 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 @@ -323,11 +351,11 @@ tls13orLater :: MonadIO m => Context -> m Bool tls13orLater ctx = do ev <- liftIO $ usingState ctx $ getVersionWithDefault TLS10 -- fixme 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 @@ -335,5 +363,5 @@ getCertRequest13 ctx context = do l <- readIORef ref let (matched, others) = partition (\(CertRequest13 c _) -> context == c) l case matched of - [] -> return Nothing - (certReq:_) -> writeIORef ref others >> return (Just certReq) + [] -> return Nothing + (certReq : _) -> writeIORef ref others >> return (Just certReq) diff --git a/core/Network/TLS/Core.hs b/core/Network/TLS/Core.hs index 61ad3a716..993f90a66 100644 --- a/core/Network/TLS/Core.hs +++ b/core/Network/TLS/Core.hs @@ -1,63 +1,69 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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 + sendPacket, + recvPacket, -- * 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, when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as L 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 (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 @@ -73,11 +79,11 @@ bye ctx = liftIO $ do -- 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 sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. @@ -95,8 +101,8 @@ sendData :: MonadIO m => Context -> L.ByteString -> m () sendData ctx dataToSend = liftIO $ do tls13 <- tls13orLater ctx let sendP - | tls13 = sendPacket13 ctx . AppData13 - | otherwise = sendPacket ctx . AppData + | tls13 = sendPacket13 ctx . AppData13 + | otherwise = sendPacket ctx . AppData withWriteLock ctx $ do checkValid ctx -- All chunks are protected with the same write lock because we don't @@ -125,108 +131,123 @@ recvData1 :: Context -> IO B.ByteString recvData1 ctx = do pkt <- recvPacket 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 + 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) + ) - 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 "") = recvData1 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 (sendPacket 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 + 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 | 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 + 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 = "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 () + loopHandshake13 (ClientHello13{} : _) = do + let reason = "Client hello is not allowed" + 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 - -- 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 + 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 -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is @@ -235,22 +256,24 @@ recvData13 ctx = do sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] keyUpdate ctx getTxState setTxState 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 + 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 $ case action of PendingAction needAligned pa -> do when needAligned $ checkAlignment hs @@ -260,63 +283,83 @@ recvData13 ctx = do d <- transcriptHash ctx processHandshake13 ctx h pa d h - loopHandshake13 hs + 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 ()) -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. diff --git a/core/Network/TLS/Credentials.hs b/core/Network/TLS/Credentials.hs index 242b65153..91294f287 100644 --- a/core/Network/TLS/Credentials.hs +++ b/core/Network/TLS/Credentials.hs @@ -1,34 +1,34 @@ +{-# LANGUAGE CPP #-} + -- | -- 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 +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 +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 +46,71 @@ instance Monoid Credentials where -- | 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 +120,71 @@ credentialCanDecrypt (chain, priv) = 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.SignatureDSS 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/core/Network/TLS/Crypto.hs b/core/Network/TLS/Crypto.hs index d849474ae..f47c374ae 100644 --- a/core/Network/TLS/Crypto.hs +++ b/core/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 - - , module Network.TLS.Crypto.DH - , module Network.TLS.Crypto.IES - , module Network.TLS.Crypto.Types +{-# OPTIONS_HADDOCK hide #-} + +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.Ed448 as Ed448 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 @@ type PublicKey = PubKey {-# 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 - -findKeyExchangeSignatureAlg :: (PubKey, PrivKey) -> Maybe KeyExchangeSignatureAlg + 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 + +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_DSS + (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 Just prms = dhParamsForGroup grp + ] findEllipticCurveGroup :: PubKeyEC -> Maybe Group findEllipticCurveGroup ecPub = @@ -118,16 +124,16 @@ findEllipticCurveGroup ecPub = 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 (HashContext (ContextSimple h)) b = HashContext $ ContextSimple (H.ha 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 @@ hashFinal (HashContextSSL sha1Ctx md5Ctx) = 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 @@ hashName = show -- | 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 SHA512 = 64 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 @@ hashBlockSize SHA1_MD5 = 64 {- 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 @@ kxCanUseRSApkcs1 pk h = RSA.public_size pk >= tLen + 11 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 @@ kxCanUseRSApss pk h = numBits (RSA.public_n pk) >= 16 * hashDigestSize h + 10 -- Signature algorithm and associated parameters. -- -- FIXME add RSAPSSParams -data SignatureParams = - RSAParams Hash RSAEncoding +data SignatureParams + = RSAParams Hash RSAEncoding | DSSParams - | ECDSAParams Hash + | 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) DSSParams 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,33 +298,34 @@ kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = 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 = @@ -321,19 +333,28 @@ kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApss) msg = kxSign (PrivKeyDSA pk) (PubKeyDSA _) DSSParams 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 (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = 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 - -rsapssSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString) +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 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/core/Network/TLS/Crypto/DH.hs b/core/Network/TLS/Crypto/DH.hs index 9d1c4a7a8..3f69f8a9c 100644 --- a/core/Network/TLS/Crypto/DH.hs +++ b/core/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 @@ dhParams p g = DH.Params p g (numBits p) 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 @@ -60,7 +59,7 @@ dhValid :: DHParams -> Integer -> Bool 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/core/Network/TLS/Crypto/IES.hs b/core/Network/TLS/Crypto/IES.hs index 96451c625..174e818ce 100644 --- a/core/Network/TLS/Crypto/IES.hs +++ b/core/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.Crypto.Types 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,50 @@ dhParamsForGroup FFDHE3072 = Just ffdhe3072 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 -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 +136,15 @@ gen :: MonadRandom r -> 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 +161,36 @@ groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub 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 +198,7 @@ getPubShared' params expBits pub 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 +214,7 @@ groupGetShared _ _ = Nothing 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 +234,9 @@ enc :: Params -> PublicNumber -> ByteString 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 diff --git a/core/Network/TLS/Crypto/Types.hs b/core/Network/TLS/Crypto/Types.hs index 90220c5de..fdef8244c 100644 --- a/core/Network/TLS/Crypto/Types.hs +++ b/core/Network/TLS/Crypto/Types.hs @@ -4,20 +4,28 @@ -- Maintainer : Kazu Yamamoto -- Stability : experimental -- Portability : unknown --- module Network.TLS.Crypto.Types where -data Group = P256 | P384 | P521 | X25519 | X448 - | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 - deriving (Eq, Show) +data Group + = P256 + | P384 + | P521 + | X25519 + | X448 + | FFDHE2048 + | FFDHE3072 + | FFDHE4096 + | FFDHE6144 + | FFDHE8192 + deriving (Eq, Show) 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] -- Key-exchange signature algorithm, in close relation to ciphers -- (before TLS 1.3). data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA - deriving (Show, Eq) + deriving (Show, Eq) diff --git a/core/Network/TLS/ErrT.hs b/core/Network/TLS/ErrT.hs index fd300bfa6..ef18d91bb 100644 --- a/core/Network/TLS/ErrT.hs +++ b/core/Network/TLS/ErrT.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | -- Module : Network.TLS.ErrT -- License : BSD-style @@ -6,14 +8,13 @@ -- Portability : unknown -- -- a simple compat ErrorT and other error stuff -{-# LANGUAGE CPP #-} -module Network.TLS.ErrT - ( runErrT - , ErrT - , MonadError(..) - ) where +module Network.TLS.ErrT ( + runErrT, + ErrT, + MonadError (..), +) where -import Control.Monad.Except (MonadError(..)) +import Control.Monad.Except (MonadError (..)) import Control.Monad.Trans.Except (ExceptT, runExceptT) runErrT :: ExceptT e m a -> m (Either e a) diff --git a/core/Network/TLS/Extension.hs b/core/Network/TLS/Extension.hs index a355545dc..92e745ea1 100644 --- a/core/Network/TLS/Extension.hs +++ b/core/Network/TLS/Extension.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} + -- | -- Module : Network.TLS.Extension -- License : BSD-style @@ -7,21 +8,114 @@ -- Portability : unknown -- -- basic extensions are defined in RFC 6066 --- -module Network.TLS.Extension - ( Extension(..) - , supportedExtensions - , definedExtensions +module Network.TLS.Extension ( + Extension (..), + supportedExtensions, + definedExtensions, -- all extensions ID supported - , extensionID_ServerName + 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, + -- 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 + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC + +import Network.TLS.Crypto.Types +import Network.TLS.Struct ( + DistinguishedName, + EnumSafe16 (..), + EnumSafe8 (..), + ExtensionID, + HashAndSignatureAlgorithm, + ) +import Network.TLS.Types (HostName, Version (..)) + +import Network.TLS.Imports +import Network.TLS.Packet ( + getBinaryVersion, + getDNames, + getSignatureHashAlgorithm, + putBinaryVersion, + putDNames, + putSignatureHashAlgorithm, + ) +import Network.TLS.Wire + +------------------------------------------------------------ + +-- central list defined in +extensionID_ServerName , extensionID_MaxFragmentLength - , extensionID_SecureRenegotiation - , extensionID_ApplicationLayerProtocolNegotiation - , extensionID_ExtendedMasterSecret + , extensionID_ClientCertificateUrl + , extensionID_TrustedCAKeys + , extensionID_TruncatedHMAC + , extensionID_StatusRequest + , extensionID_UserMapping + , extensionID_ClientAuthz + , extensionID_ServerAuthz + , extensionID_CertType , extensionID_NegotiatedGroups , extensionID_EcPointFormats - , extensionID_Heartbeat + , 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 @@ -32,138 +126,48 @@ module Network.TLS.Extension , extensionID_PostHandshakeAuth , extensionID_SignatureAlgorithmsCert , extensionID_KeyShare + , extensionID_SecureRenegotiation , extensionID_QuicTransportParameters - -- 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 - -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.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 +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 +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 +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 +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 ------------------------------------------------------------ @@ -208,38 +212,40 @@ definedExtensions = -- | 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 = + [ 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 + ] ------------------------------------------------------------ -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 +254,23 @@ class Extension a where -- | 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 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 +278,13 @@ decodeServerName = runGetMaybe $ do ServerName <$> getList len getServerName where getServerName = do - ty <- getWord8 + ty <- getWord8 snameParsed <- getOpaque16 let !sname = B.copy snameParsed name = case ty of - 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion - _ -> ServerNameOther (ty, sname) - return (1+2+B.length sname, name) + 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion + _ -> ServerNameOther (ty, sname) + return (1 + 2 + B.length sname, name) ------------------------------------------------------------ @@ -288,21 +296,23 @@ decodeServerName = runGetMaybe $ do -- handshake with an "illegal_parameter" alert. -- -- So, if a server receives MaxFragmentLengthOther, it must send the alert. -data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum - | MaxFragmentLengthOther Word8 - deriving (Show,Eq) - -data MaxFragmentEnum = MaxFragment512 - | MaxFragment1024 - | MaxFragment2048 - | MaxFragment4096 - deriving (Show,Eq) +data MaxFragmentLength + = MaxFragmentLength MaxFragmentEnum + | MaxFragmentLengthOther Word8 + deriving (Show, Eq) + +data MaxFragmentEnum + = MaxFragment512 + | MaxFragment1024 + | MaxFragment2048 + | MaxFragment4096 + deriving (Show, Eq) instance Extension MaxFragmentLength where extensionID _ = extensionID_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 +320,7 @@ instance Extension MaxFragmentLength where 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 @@ -325,7 +335,7 @@ decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8 -- | Secure Renegotiation data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString) - deriving (Show,Eq) + deriving (Show, Eq) instance Extension SecureRenegotiation where extensionID _ = extensionID_SecureRenegotiation @@ -334,15 +344,18 @@ instance Extension SecureRenegotiation where 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 (Just svd) + MsgTClientHello -> return $ SecureRenegotiation opaque Nothing + _ -> 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 @@ -351,9 +364,10 @@ instance Extension ApplicationLayerProtocolNegotiation where 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 @@ -366,18 +380,18 @@ decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do ------------------------------------------------------------ -- | Extended Master Secret -data ExtendedMasterSecret = ExtendedMasterSecret deriving (Show,Eq) +data ExtendedMasterSecret = ExtendedMasterSecret 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" + extensionDecode _ _ = error "extensionDecode: ExtendedMasterSecret" ------------------------------------------------------------ -newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) +newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show, Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where @@ -385,7 +399,7 @@ instance Extension NegotiatedGroups where extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups extensionDecode MsgTClientHello = decodeNegotiatedGroups extensionDecode MsgTEncryptedExtensions = decodeNegotiatedGroups - extensionDecode _ = error "extensionDecode: NegotiatedGroups" + extensionDecode _ = error "extensionDecode: NegotiatedGroups" decodeNegotiatedGroups :: ByteString -> Maybe NegotiatedGroups decodeNegotiatedGroups = @@ -393,13 +407,14 @@ decodeNegotiatedGroups = ------------------------------------------------------------ -newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) +newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] + deriving (Show, Eq) -data EcPointFormat = - EcPointFormat_Uncompressed +data EcPointFormat + = EcPointFormat_Uncompressed | EcPointFormat_AnsiX962_compressed_prime | EcPointFormat_AnsiX962_compressed_char2 - deriving (Show,Eq) + deriving (Show, Eq) instance EnumSafe8 EcPointFormat where fromEnumSafe8 EcPointFormat_Uncompressed = 0 @@ -428,26 +443,26 @@ decodeEcPointFormatsSupported = -- Fixme: this is incomplete -- newtype SessionTicket = SessionTicket ByteString data SessionTicket = SessionTicket - deriving (Show,Eq) + deriving (Show, Eq) 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" + extensionDecode _ = error "extensionDecode: SessionTicket" ------------------------------------------------------------ -newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) +newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show, Eq) -data HeartBeatMode = - HeartBeat_PeerAllowedToSend +data HeartBeatMode + = HeartBeat_PeerAllowedToSend | HeartBeat_PeerNotAllowedToSend - deriving (Show,Eq) + deriving (Show, Eq) instance EnumSafe8 HeartBeatMode where - fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1 + fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1 fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2 toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend @@ -459,96 +474,106 @@ instance Extension HeartBeat where extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 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" + Just m -> return $ HeartBeat m + Nothing -> fail "unknown HeartBeatMode" ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) +newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] + deriving (Show, Eq) instance Extension SignatureAlgorithms where extensionID _ = extensionID_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 + 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 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 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 where getVer = do ver <- getBinaryVersion - return (2,ver) + return (2, ver) extensionDecode MsgTServerHello = runGetMaybe $ do mver <- getBinaryVersion case mver of - Just ver -> return $ SupportedVersionsServerHello ver - Nothing -> fail "extensionDecode: SupportedVersionsServerHello" + Just ver -> return $ SupportedVersionsServerHello ver + Nothing -> fail "extensionDecode: SupportedVersionsServerHello" 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 @@ -557,8 +582,8 @@ getKeyShareEntry = do key <- getBytes l let !len = l + 4 case toEnumSafe16 g of - Nothing -> return (len, Nothing) - Just grp -> return (len, Just $ KeyShareEntry grp key) + Nothing -> return (len, Nothing) + Just grp -> return (len, Just $ KeyShareEntry grp key) putKeyShareEntry :: KeyShareEntry -> Put putKeyShareEntry (KeyShareEntry grp key) = do @@ -566,11 +591,11 @@ putKeyShareEntry (KeyShareEntry grp key) = do 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 @@ -580,21 +605,21 @@ instance Extension KeyShare where mapM_ putKeyShareEntry kses extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse extensionEncode (KeyShareHRR grp) = runPut $ putWord16 $ fromEnumSafe16 grp - extensionDecode MsgTServerHello = runGetMaybe $ do + 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 + Nothing -> fail "decoding KeyShare for HRR" + Just grp -> return $ KeyShareHRR grp extensionDecode _ = error "extensionDecode: KeyShare" ------------------------------------------------------------ @@ -602,31 +627,35 @@ instance Extension KeyShare where data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show) instance EnumSafe8 PskKexMode where - fromEnumSafe8 PSK_KE = 0 + fromEnumSafe8 PSK_KE = 0 fromEnumSafe8 PSK_DHE_KE = 1 toEnumSafe8 0 = Just PSK_KE toEnumSafe8 1 = Just PSK_DHE_KE toEnumSafe8 _ = Nothing -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 + extensionEncode (PskKeyExchangeModes pkms) = + runPut $ + putWords8 $ + map fromEnumSafe8 pkms + extensionDecode MsgTClientHello = + runGetMaybe $ + PskKeyExchangeModes . mapMaybe toEnumSafe8 <$> 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 @@ -638,10 +667,13 @@ instance Extension PreSharedKey where 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,17 +695,19 @@ instance Extension PreSharedKey where ------------------------------------------------------------ -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 + 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" ------------------------------------------------------------ @@ -683,7 +717,7 @@ instance Extension Cookie where extensionID _ = extensionID_Cookie extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16) - extensionDecode _ = error "extensionDecode: Cookie" + extensionDecode _ = error "extensionDecode: Cookie" ------------------------------------------------------------ @@ -692,10 +726,11 @@ newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName] instance Extension CertificateAuthorities where extensionID _ = extensionID_CertificateAuthorities - extensionEncode (CertificateAuthorities names) = runPut $ - putDNames names + 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/core/Network/TLS/Extra.hs b/core/Network/TLS/Extra.hs index f75153178..3413e9c35 100644 --- a/core/Network/TLS/Extra.hs +++ b/core/Network/TLS/Extra.hs @@ -6,10 +6,10 @@ -- Portability : unknown -- -- default values and ciphers -module Network.TLS.Extra - ( module Network.TLS.Extra.Cipher - , module Network.TLS.Extra.FFDHE - ) where +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/core/Network/TLS/Extra/Cipher.hs b/core/Network/TLS/Extra/Cipher.hs index 5ddf485cc..135e8e09a 100644 --- a/core/Network/TLS/Extra/Cipher.hs +++ b/core/Network/TLS/Extra/Cipher.hs @@ -4,83 +4,83 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Extra.Cipher - ( +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 + 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 + 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 + 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 + 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 Data.Tuple (swap) import Network.TLS.Cipher import Network.TLS.Imports -import Data.Tuple (swap) +import Network.TLS.Types (Version (..)) import Crypto.Cipher.AES import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 @@ -97,105 +97,126 @@ 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)) + 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)) + 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)) + 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)) + 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 -> + 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) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) aes128ccm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 - in (\nonce d ad -> + 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) + in simpleDecrypt aeadIni ad d 16 + ) aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD aes128ccm8 BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 - in (\nonce d ad -> + 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) + in swap $ aeadSimpleEncrypt aeadIni ad d 8 + ) aes128ccm8 BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 - in (\nonce d ad -> + 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) + in simpleDecrypt aeadIni ad d 8 + ) aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD aes128gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128 - in (\nonce d ad -> + in ( \nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) aes128gcm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES128 - in (\nonce d ad -> + in ( \nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16) + in simpleDecrypt aeadIni ad d 16 + ) aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + 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) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) aes256ccm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + 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) + in simpleDecrypt aeadIni ad d 16 + ) aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm8 BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + 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) + in swap $ aeadSimpleEncrypt aeadIni ad d 8 + ) aes256ccm8 BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + 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) + in simpleDecrypt aeadIni ad d 8 + ) aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD aes256gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + in ( \nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in swap $ aeadSimpleEncrypt aeadIni ad d 16) + in swap $ aeadSimpleEncrypt aeadIni ad d 16 + ) aes256gcm BulkDecrypt key = let ctx = noFail (cipherInit key) :: AES256 - in (\nonce d ad -> + in ( \nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce) - in simpleDecrypt aeadIni ad d 16) + in simpleDecrypt aeadIni ad d 16 + ) -simpleDecrypt :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag) +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 + aead = aeadAppendHeader aeadIni header + (output, aeadFinal) = aeadDecrypt aead input + tag = aeadFinalize aeadFinal taglen noFail :: CryptoFailable a -> a noFail = throwCryptoError @@ -206,10 +227,16 @@ 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)) + 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)) + 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 @@ -224,21 +251,23 @@ rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey) chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD chacha20poly1305 BulkEncrypt key nonce = let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in (\input ad -> + 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)) + in (output, AuthTag tag) + ) chacha20poly1305 BulkDecrypt key nonce = let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key) - in (\input ad -> + 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)) + in (output, AuthTag tag) + ) data CipherSet - = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm + = SetAead [Cipher] [Cipher] [Cipher] -- gcm, chacha, ccm | SetOther [Cipher] -- Preference between AEAD ciphers having equivalent properties is based on @@ -247,9 +276,9 @@ sortOptimized :: [CipherSet] -> [Cipher] sortOptimized = concatMap f where f (SetAead gcm chacha ccm) - | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm + | AESNI `notElem` processorOptions = chacha ++ gcm ++ ccm | PCLMUL `notElem` processorOptions = ccm ++ chacha ++ gcm - | otherwise = gcm ++ ccm ++ chacha + | otherwise = gcm ++ ccm ++ chacha f (SetOther ciphers) = ciphers -- Order which is deterministic but not optimized for the CPU. @@ -278,54 +307,64 @@ ciphersuite_default_det = sortDeterministic sets_default sets_default :: [CipherSet] sets_default = - [ -- First the PFS + GCM + SHA2 ciphers + [ -- 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 ] + [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 ] + [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_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 ] + [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." #-} +{-# 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 @@ -334,7 +373,11 @@ sets_default = 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." #-} +{-# 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] @@ -342,21 +385,27 @@ 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_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 - ] +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 @@ -375,782 +424,878 @@ 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 + [ -- 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 + , -- 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 ] + , -- 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_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] +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 - } +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 - } +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 } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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_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_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 - } +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 - } +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 - } +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 - } +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 - } +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 - } +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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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 - } +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 diff --git a/core/Network/TLS/Extra/FFDHE.hs b/core/Network/TLS/Extra/FFDHE.hs index b01a5ec58..12aeff4a5 100644 --- a/core/Network/TLS/Extra/FFDHE.hs +++ b/core/Network/TLS/Extra/FFDHE.hs @@ -15,48 +15,58 @@ import Network.TLS.Crypto.DH (DHParams) -- 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/core/Network/TLS/Handshake.hs b/core/Network/TLS/Handshake.hs index b601c1fde..81fe90adc 100644 --- a/core/Network/TLS/Handshake.hs +++ b/core/Network/TLS/Handshake.hs @@ -4,21 +4,20 @@ -- 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 diff --git a/core/Network/TLS/Handshake/Certificate.hs b/core/Network/TLS/Handshake/Certificate.hs index 0846826cd..626b471d1 100644 --- a/core/Network/TLS/Handshake/Certificate.hs +++ b/core/Network/TLS/Handshake/Certificate.hs @@ -4,22 +4,21 @@ -- 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 +40,17 @@ rejectOnException :: SomeException -> IO CertificateUsage 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/core/Network/TLS/Handshake/Client.hs b/core/Network/TLS/Handshake/Client.hs index 3bc2529e4..a4c48d607 100644 --- a/core/Network/TLS/Handshake/Client.hs +++ b/core/Network/TLS/Handshake/Client.hs @@ -1,41 +1,41 @@ {-# 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 +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 qualified Data.ByteString as B +import Data.X509 (ExtKeyUsageFlag (..)) import Network.TLS.Cipher import Network.TLS.Compression +import Network.TLS.Context.Internal import Network.TLS.Credentials -import Network.TLS.Packet hiding (getExtensions) +import Network.TLS.Crypto 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.Packet hiding (getExtensions) +import Network.TLS.Parameters +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 import Network.TLS.Types +import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) 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 Control.Monad.State.Strict import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Common @@ -51,17 +51,21 @@ 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 +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 + 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 @@ -72,7 +76,12 @@ handshakeClient cparams ctx = do -- 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' + :: ClientParams + -> Context + -> [Group] + -> Maybe (ClientRandom, Session, Version) + -> IO () handshakeClient' cparams ctx groups mparams = do updateMeasure ctx incrementNbHandshakes (crand, clientSession) <- generateClientHelloParams @@ -80,67 +89,84 @@ handshakeClient' cparams ctx groups mparams = do recvServerHello clientSession sentExtensions ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ - throwCore $ Error_Protocol "version changed after hello retry" IllegalParameter + 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 + 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 + 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 + , -- , sessionTicketExtension + signatureAlgExtension + , -- , heartbeatExtension + versionExtension , earlyDataExtension rtt0 , keyshareExtension , cookieExtension @@ -149,208 +175,244 @@ handshakeClient' cparams ctx groups mparams = do , 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 $ + 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 + 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 + 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 + :: 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 + 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 + 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 @@ -409,25 +471,26 @@ storePrivInfoClient ctx cTypes (cc, privkey) = do -- 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 + Nothing -> return Nothing Just cbdata -> do let callback = onCertificateRequest $ clientHooks cparams - chain <- liftIO $ callback cbdata `catchException` - throwMiscErrorOnException "certificate request callback failed" + 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 + 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 @@ -437,44 +500,51 @@ clientChain cparams ctx = -- 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 + :: 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 + let want = + (&&) + <$> isCompatible pubKey + <*> flip elem hashSigs case find want cHashSigs of Just best -> return best - Nothing -> throwCore $ Error_Protocol (keyerr pubKey) HandshakeFailure + 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 + :: [HashAndSignatureAlgorithm] + -> [CertificateType] supportedCtypes hashAlgs = nub $ foldr ctfilter [] hashAlgs where ctfilter x acc = case hashSigToCertType x of - Just cType | cType <= lastSupportedCertificateType - -> cType : acc - _ -> acc + Just cType + | cType <= lastSupportedCertificateType -> + cType : acc + _ -> acc + -- -clientSupportedCtypes :: Context - -> [CertificateType] +clientSupportedCtypes + :: Context + -> [CertificateType] clientSupportedCtypes ctx = supportedCtypes $ supportedHashSignatures $ ctxSupported ctx + -- -sigAlgsToCertTypes :: Context - -> [HashAndSignatureAlgorithm] - -> [CertificateType] +sigAlgsToCertTypes + :: Context + -> [HashAndSignatureAlgorithm] + -> [CertificateType] sigAlgsToCertTypes ctx hashSigs = filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx @@ -494,133 +564,149 @@ sigAlgsToCertTypes ctx hashSigs = 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 + 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 - 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. + 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. -- - 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] + 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 + | 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 + 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 = + | extID == extensionID_PreSharedKey = setTLS13PreSharedKey $ extensionDecode MsgTServerHello content processServerExtension _ = return () @@ -635,35 +721,53 @@ throwMiscErrorOnException msg e = -- 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 + :: 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 + 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 + 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 + | i == extensionID_Cookie = False -- for HRR + | otherwise = i `notElem` sentExts when (any checkExt exts) $ - throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension + 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 + 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) + setTLS13Cookie + ( guard isHRR + >> extensionLookup extensionID_Cookie exts + >>= extensionDecode MsgTServerHello + ) setSession serverSession (isJust resumingSession) setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts @@ -681,132 +785,169 @@ onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan ser -- client-side enabled protocol versions. -- when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $ - throwCore $ Error_Protocol "version downgrade detected" IllegalParameter + 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 + 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 + 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 + 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 - + 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") +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") +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 - + 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 + 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) @@ -824,43 +965,47 @@ processServerHelloDone _ p = unexpected (show p) (Just "server hello data") 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 - ] + 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' + :: 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) + handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret, serverHandshakeSecret) contextSync ctx $ RecvServerHello handSecInfo - (rtt0accepted,eexts) <- runRecvHandshake13 $ do + (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 + runPacketFlight ctx $ + sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) setTxState ctx usedHash usedCipher clientHandshakeSecret @@ -873,7 +1018,7 @@ handshakeClient13' cparams ctx groupSent choice = do handshakeTerminate13 ctx where usedCipher = cCipher choice - usedHash = cHash choice + usedHash = cHash choice hashSize = hashDigestSize usedHash @@ -899,59 +1044,68 @@ handshakeClient13' cparams ctx groupSent choice = 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 + 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 + throwCore $ + Error_Protocol "broken key_share" IllegalParameter unless (groupSent == Just grp) $ - throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter + 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 + 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) + 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 + setCertReqToken Nothing + setCertReqCBdata Nothing + -- setCertReqSigAlgsCert Nothing expectCertAndVerify other expectCertAndVerify (Certificate13 _ cc _) = do @@ -976,10 +1130,11 @@ handshakeClient13' cparams ctx groupSent choice = do resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret usingHState ctx $ setTLS13ResumptionSecret resumptionSecret -processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () +processCertRequest13 + :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () processCertRequest13 ctx token exts = do let hsextID = extensionID_SignatureAlgorithms - -- caextID = extensionID_SignatureAlgorithmsCert + -- caextID = extensionID_SignatureAlgorithmsCert dNames <- canames -- The @signature_algorithms@ extension is mandatory. hsAlgs <- extalgs hsextID unsighash @@ -991,32 +1146,37 @@ processCertRequest13 ctx token exts = do -- Unused: -- caAlgs <- extalgs caextID uncertsig usingHState ctx $ do - setCertReqToken $ Just token + setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) - -- setCertReqSigAlgsCert caAlgs where + -- setCertReqSigAlgsCert caAlgs + 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 + 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] + 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 () +{- 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 @@ -1033,18 +1193,21 @@ sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do 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] + _ -> 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 + 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 +setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts + >>= extensionDecode msgt of Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of @@ -1061,11 +1224,16 @@ postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxState ctx unless (level == CryptApplicationSecret) $ - throwCore $ Error_Protocol "unexpected post-handshake authentication request" UnexpectedMessage + 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 + throwCore $ + Error_Protocol + "unexpected handshake message received in postHandshakeAuthClientWith" + UnexpectedMessage contextSync :: Context -> ClientState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of diff --git a/core/Network/TLS/Handshake/Common.hs b/core/Network/TLS/Handshake/Common.hs index 7bf91aa90..997530f55 100644 --- a/core/Network/TLS/Handshake/Common.hs +++ b/core/Network/TLS/Handshake/Common.hs @@ -1,56 +1,59 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -module Network.TLS.Handshake.Common - ( handshakeFailed - , handleException - , unexpected - , newSession - , handshakeTerminate + +module Network.TLS.Handshake.Common ( + handshakeFailed, + handleException, + unexpected, + newSession, + handshakeTerminate, + -- * sending packets - , sendChangeCipherAndFinish + sendChangeCipherAndFinish, + -- * receiving packets - , recvChangeCipherAndFinish - , RecvState(..) - , runRecvState - , recvPacketHandshake - , onRecvStateHandshake - , ensureRecvComplete - , processExtendedMasterSec - , extensionLookup - , getSessionData - , storePrivInfo - , isSupportedGroup - , checkSupportedGroup - , errorToAlert - , errorToAlertMessage - ) where + recvChangeCipherAndFinish, + RecvState (..), + runRecvState, + recvPacketHandshake, + onRecvStateHandshake, + ensureRecvComplete, + processExtendedMasterSec, + extensionLookup, + getSessionData, + storePrivInfo, + isSupportedGroup, + checkSupportedGroup, + errorToAlert, + errorToAlertMessage, +) where -import qualified Data.ByteString as B import Control.Concurrent.MVar +import qualified Data.ByteString as B -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.State -import Network.TLS.Record.State +import Network.TLS.IO +import Network.TLS.Imports import Network.TLS.Measurement +import Network.TLS.Parameters +import Network.TLS.Record.State +import Network.TLS.Session +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.Exception (IOException, fromException, handle, throwIO) import Control.Monad.State.Strict -import Control.Exception (IOException, handle, fromException, throwIO) import Data.IORef (writeIORef) handshakeFailed :: TLSError -> IO () @@ -62,46 +65,46 @@ handleException ctx f = catchException f $ \exception -> do -- 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) 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 sendPacket13 ctx $ Alert13 [errorToAlert tlserror] + else sendPacket 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 () @@ -112,44 +115,53 @@ handshakeTerminate ctx = do Session (Just sessionId) -> do sessionData <- getSessionData ctx let !sessionId' = B.copy sessionId - liftIO $ sessionEstablish (sharedSessionManager $ ctxShared ctx) sessionId' (fromJust "session-data" sessionData) + liftIO $ + sessionEstablish + (sharedSessionManager $ ctxShared ctx) + sessionId' + (fromJust "session-data" sessionData) _ -> return () -- forget most handshake data and reset bytes counters. - liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> + 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 - } + return $ + Just + (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) + { hstServerRandom = hstServerRandom hshake + , hstMasterSecret = hstMasterSecret hshake + , hstExtendedMasterSec = hstExtendedMasterSec hshake + , hstNegotiatedGroup = hstNegotiatedGroup hshake + } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. setEstablished ctx Established return () -sendChangeCipherAndFinish :: Context - -> Role - -> IO () +sendChangeCipherAndFinish + :: Context + -> Role + -> IO () sendChangeCipherAndFinish ctx role = do sendPacket ctx ChangeCipherSpec liftIO $ contextFlush ctx - cf <- usingState_ ctx getVersion >>= \ver -> usingHState ctx $ getHandshakeDigest ver role + 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") + 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") -data RecvState m = - RecvStateNext (Packet -> m (RecvState m)) +data RecvState m + = RecvStateNext (Packet -> m (RecvState m)) | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone @@ -164,45 +176,54 @@ recvPacketHandshake ctx = do 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 _ (RecvStateNext f) hms = f (Handshake hms) +onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do nstate <- f x processHandshake ctx x onRecvStateHandshake ctx nstate xs -onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing +onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing runRecvState :: Context -> RecvState IO -> IO () -runRecvState _ RecvStateDone = return () +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 ctx iniState = + recvPacketHandshake ctx + >>= onRecvStateHandshake ctx iniState + >>= 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 + :: 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" + | ver < TLS10 = return False + | ver > TLS12 = error "EMS processing is not compatible with TLS 1.3" | ems == NoEMS = return False - | otherwise = + | 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" + Nothing + | ems == RequireEMS -> throwCore $ Error_Protocol err HandshakeFailure + | otherwise -> return False + where + ems = supportedExtendedMasterSec (ctxSupported ctx) + err = "peer does not support Extended Master Secret" getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do @@ -210,45 +231,51 @@ getSessionData ctx = do sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) !ems <- usingHState ctx getExtendedMasterSec - tx <- liftIO $ readMVar (ctxTxState ctx) + tx <- liftIO $ readMVar (ctxTxState ctx) alpn <- usingState_ ctx getNegotiatedProtocol - let !cipher = cipherID $ fromJust "cipher" $ stCipher tx + let !cipher = cipherID $ fromJust "cipher" $ stCipher tx !compression = compressionID $ stCompression tx 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 CertificateChain (c : _) = 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 diff --git a/core/Network/TLS/Handshake/Common13.hs b/core/Network/TLS/Handshake/Common13.hs index 70bcb38f0..6b425339b 100644 --- a/core/Network/TLS/Handshake/Common13.hs +++ b/core/Network/TLS/Handshake/Common13.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Common13 @@ -6,49 +8,48 @@ -- 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, + 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 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 @@ -85,10 +86,13 @@ makeFinished ctx usedHash baseKey = do liftIO $ writeIORef (ctxFinished ctx) (Just finished) pure $ Finished13 finished -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) @@ -102,15 +106,15 @@ makeVerifyData usedHash baseKey = hmac usedHash finishedKey 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 +128,12 @@ makeClientKeyShare ctx grp = do 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,20 +145,35 @@ serverContextString = "TLS 1.3, server CertificateVerify" 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 + let ctxStr + | cc == 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 + let ctxStr + | cc == ClientRole = serverContextString -- opposite context + | otherwise = clientContextString target = makeTarget ctxStr hashValue sigParams = signatureParams pub (Just hs) checkHashSignatureValid13 hs @@ -167,7 +188,13 @@ makeTarget contextString hashValue = runPut $ do 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) @@ -175,12 +202,18 @@ sign ctx pub hs target = liftIO $ do ---------------------------------------------------------------- -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,17 +227,17 @@ replacePSKBinder :: ByteString -> ByteString -> ByteString 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 ---------------------------------------------------------------- @@ -217,19 +250,21 @@ sendChangeCipherSpec13 ctx = do handshakeTerminate13 :: Context -> IO () handshakeTerminate13 ctx = do -- forget most handshake data - liftIO $ modifyMVar_ (ctxHandshake ctx) $ \ mhshake -> + 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 - } + 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 + } -- forget handshake data stored in TLS state usingState_ ctx $ do setTLS13KeyShare Nothing @@ -241,18 +276,23 @@ handshakeTerminate13 ctx = do 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] + | otherwise = [ExtensionRaw extensionID_CertificateAuthorities caDnsEncoded] crexts = ExtensionRaw extensionID_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 @@ -286,9 +326,10 @@ getAge tinfo = do checkFreshness :: TLS13TicketInfo -> Second -> IO Bool checkFreshness tinfo 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 @@ -309,35 +350,39 @@ millisecondsFromBase (UnixTime (CTime s) us) = 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 getNegotiatedGroup + 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 + 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. @@ -345,24 +390,27 @@ ensureNullCompression compression = -- 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 +419,18 @@ getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13 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,25 +450,26 @@ checkHashSignatureValid13 hs = 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 - } +data CipherChoice = CipherChoice + { cVersion :: Version + , cCipher :: Cipher + , cHash :: Hash + , cZero :: !ByteString + } makeCipherChoice :: Version -> Cipher -> CipherChoice makeCipherChoice ver cipher = CipherChoice ver cipher h zero @@ -430,18 +479,22 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero ---------------------------------------------------------------- -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 @@ -457,34 +510,56 @@ initEarlySecret choice mpsk = BaseSecret sec usedHash = cHash choice zero = cZero choice zeroOrPSK = case mpsk of - Just psk -> psk - Nothing -> zero - -calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret -> ByteString - -> IO (SecretTriple HandshakeSecret) + Just psk -> psk + Nothing -> zero + +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 + 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,8 +567,11 @@ calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do 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 @@ -501,7 +579,8 @@ calculateResumptionSecret ctx choice (BaseSecret sec) = do 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 +596,13 @@ checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key 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 diff --git a/core/Network/TLS/Handshake/Control.hs b/core/Network/TLS/Handshake/Control.hs index 8fb53f4ee..bcc190ff7 100644 --- a/core/Network/TLS/Handshake/Control.hs +++ b/core/Network/TLS/Handshake/Control.hs @@ -4,15 +4,14 @@ -- 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 +26,24 @@ type NegotiatedProtocol = ByteString -- | 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/core/Network/TLS/Handshake/Key.hs b/core/Network/TLS/Handshake/Key.hs index 0fb5364e5..3e4f5916e 100644 --- a/core/Network/TLS/Handshake/Key.hs +++ b/core/Network/TLS/Handshake/Key.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} + -- | -- Module : Network.TLS.Handshake.Key -- License : BSD-style @@ -7,36 +8,35 @@ -- 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 +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 (getVersion, 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 +48,7 @@ encryptRSA ctx content = do 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,7 +57,7 @@ signPrivate ctx _ params content = do 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) @@ -68,7 +68,8 @@ decryptRSA ctx econtent = do let cipher = if ver < TLS10 then econtent else 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 +80,32 @@ generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp 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 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 -- | 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 +114,13 @@ versionCompatible _ _ = False 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 +128,12 @@ checkDigitalSignatureKey usedVersion key = do 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,7 +145,7 @@ getLocalPublicKey ctx = satisfiesEcPredicate :: (Group -> Bool) -> PubKey -> Bool satisfiesEcPredicate p (PubKeyEC ecPub) = maybe False p $ findEllipticCurveGroup ecPub -satisfiesEcPredicate _ _ = True +satisfiesEcPredicate _ _ = True ---------------------------------------------------------------- @@ -169,10 +176,10 @@ logKey :: LogLabel a => Context -> a -> IO () 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/core/Network/TLS/Handshake/Process.hs b/core/Network/TLS/Handshake/Process.hs index bf41c464c..8532e97c2 100644 --- a/core/Network/TLS/Handshake/Process.hs +++ b/core/Network/TLS/Handshake/Process.hs @@ -6,12 +6,11 @@ -- Portability : unknown -- -- process handshake message received --- -module Network.TLS.Handshake.Process - ( processHandshake - , processHandshake13 - , startHandshake - ) where +module Network.TLS.Handshake.Process ( + processHandshake, + processHandshake13, + startHandshake, +) where import Network.TLS.Context.Internal import Network.TLS.Crypto @@ -29,14 +28,14 @@ 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.Types (MasterSecret (..), Role (..), invertRole) 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) +import Data.X509 (Certificate (..), CertificateChain (..), getCertificate) processHandshake :: Context -> Handshake -> IO () processHandshake ctx hs = do @@ -47,40 +46,48 @@ processHandshake ctx hs = do -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} when (secureRenegotiation && (0xff `elem` cids)) $ - usingState_ ctx $ setSecureRenegotiation True + 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 () + Certificates certs -> processCertificates role certs + Finished fdata -> processClientFinished ctx fdata + _ -> return () 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 + 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 () + 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 + 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 + isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand + isHRR _ = False processHandshake13 :: Context -> Handshake13 -> IO () processHandshake13 ctx = void . updateHandshake13 ctx @@ -96,14 +103,13 @@ processClientKeyXchg ctx (CKX_RSA encryptedPremaster) = do masterSecret <- usingHState ctx $ do expectedVer <- gets hstClientVersion case ePremaster of - Left _ -> setMasterSecretFromPre rver role random + Left _ -> setMasterSecretFromPre rver role random Right premaster -> case decodePreMasterSecret premaster of - Left _ -> setMasterSecretFromPre rver role random + Left _ -> setMasterSecretFromPre rver role random Right (ver, _) | ver /= expectedVer -> setMasterSecretFromPre rver role random - | otherwise -> setMasterSecretFromPre rver role premaster + | otherwise -> setMasterSecretFromPre rver role premaster liftIO $ logKey ctx (MasterSecret masterSecret) - processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext @@ -111,30 +117,34 @@ processClientKeyXchg ctx (CKX_DH clientDHValue) = do serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams unless (dhValid params $ dhUnwrapPublic clientDHValue) $ - throwCore $ Error_Protocol "invalid client public key" IllegalParameter + throwCore $ + Error_Protocol "invalid client public key" IllegalParameter - dhpriv <- usingHState ctx getDHPrivate + 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 + 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 + (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 @@ -143,4 +153,4 @@ processClientFinished ctx fdata = do startHandshake :: Context -> Version -> ClientRandom -> IO () startHandshake ctx ver crand = let hs = Just $ newEmptyHandshake ver crand - in liftIO $ void $ swapMVar (ctxHandshake ctx) hs + in liftIO $ void $ swapMVar (ctxHandshake ctx) hs diff --git a/core/Network/TLS/Handshake/Random.hs b/core/Network/TLS/Handshake/Random.hs index 1b97bae8d..a4a8d4570 100644 --- a/core/Network/TLS/Handshake/Random.hs +++ b/core/Network/TLS/Handshake/Random.hs @@ -1,18 +1,18 @@ {-# 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 +28,15 @@ import Network.TLS.Struct -- 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 +46,14 @@ serverRandom ctx chosenVer suppVers -- 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 +65,42 @@ clientRandom :: Context -> IO ClientRandom clientRandom ctx = ClientRandom <$> getStateRNG ctx 32 hrrRandom :: ServerRandom -hrrRandom = ServerRandom $ B.pack [ - 0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11 - , 0xBE, 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91 - , 0xC2, 0xA2, 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E - , 0x07, 0x9E, 0x09, 0xE2, 0xC8, 0xA8, 0x33, 0x9C - ] +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/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs index f12fecda2..7296424a1 100644 --- a/core/Network/TLS/Handshake/Server.hs +++ b/core/Network/TLS/Handshake/Server.hs @@ -1,51 +1,51 @@ {-# 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 +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 qualified Data.ByteString as B +import Data.X509 (ExtKeyUsageFlag (..)) 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.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.Process import Network.TLS.Handshake.Random +import Network.TLS.Handshake.State +import Network.TLS.IO +import Network.TLS.Imports import Network.TLS.Measurement -import qualified Data.ByteString as B -import Data.X509 (ExtKeyUsageFlag(..)) +import Network.TLS.Parameters +import Network.TLS.Session +import Network.TLS.State +import Network.TLS.Struct +import Network.TLS.Struct13 +import Network.TLS.Types +import Network.TLS.Util (bytesEq, catchException, fromJust) -import Control.Monad.State.Strict import Control.Exception (bracket) +import Control.Monad.State.Strict -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.Common import Network.TLS.Handshake.Common13 +import Network.TLS.Handshake.Signature +import Network.TLS.Handshake.State13 +import Network.TLS.X509 -- Put the server context in handshake mode. -- @@ -58,7 +58,7 @@ handshakeServer sparams ctx = liftIO $ do hss <- recvPacketHandshake ctx case hss of [ch] -> handshakeServerWith sparams ctx ch - _ -> unexpected (show hss) (Just "client hello") + _ -> unexpected (show hss) (Just "client hello") -- | Put the server context in handshake mode. -- @@ -83,94 +83,142 @@ handshakeServer sparams ctx = liftIO $ do -- <- 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 + 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 + 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") + 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 + 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 + 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 + 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 + 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 + | 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 + 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 + 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 + 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 + :: 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) + 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 (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 @@ -187,7 +235,7 @@ handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clien -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. - let possibleGroups = negotiatedGroupsInCommon ctx exts + let possibleGroups = negotiatedGroupsInCommon ctx exts possibleECGroups = possibleGroups `intersect` availableECGroups possibleFFGroups = possibleGroups `intersect` availableFFGroups hasCommonGroupForECDHE = not (null possibleECGroups) @@ -196,115 +244,139 @@ handshakeServerWithTLS12 sparams ctx chosenVersion exts ciphers serverName clien 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 + 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 + 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 - _ -> + (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 + 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 + 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 + 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 + (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 + 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 - + 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 () + 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 @@ -324,173 +396,194 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes 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 + --- + -- 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 + -- 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 - 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. + 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. -- @@ -499,104 +592,112 @@ doHandshake sparams mcred ctx chosenVersion usedCipher usedCompression clientSes -- <- [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 + where + processClientCertificate (Certificates certs) = do + clientCertificate sparams ctx certs - expectChangeCipher ChangeCipherSpec = do - return $ RecvStateHandshake expectFinish + -- FIXME: We should check whether the certificate + -- matches our request and that we support + -- verifying with that certificate. - expectChangeCipher p = unexpected (show p) (Just "change cipher") + return $ RecvStateHandshake processClientKeyExchange + processClientCertificate p = processClientKeyExchange p - expectFinish (Finished _) = return RecvStateDone - expectFinish p = unexpected (show p) (Just "Handshake Finished") + -- 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") -checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain + -- 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 + Just cc + | isNullCertificateChain cc -> throwCore throwerror + | otherwise -> return cc -hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] +hashAndSignaturesInCommon + :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx exts = - let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of + 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)] + Nothing -> + [ (HashSHA1, SignatureECDSA) + , (HashSHA1, SignatureRSA) + , (HashSHA1, SignatureDSS) + ] Just (SignatureAlgorithms sas) -> sas sHashSigs = supportedHashSignatures $ ctxSupported ctx - -- The values in the "signature_algorithms" extension + 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'. - in sHashSigs `intersect` cHashSigs + sHashSigs `intersect` cHashSigs negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] -negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of +negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts + >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) - in serverGroups `intersect` clientGroups - _ -> [] + in serverGroups `intersect` clientGroups + _ -> [] credentialDigitalSignatureKey :: Credential -> Maybe PubKey credentialDigitalSignatureKey cred | isDigitalSignaturePair keys = Just pubkey | otherwise = Nothing - where keys@(pubkey, _) = credentialPublicPrivateKeys cred + 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 + :: 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 ] + let orderedPairs = sortOn fst [(rankFun cred, cred) | cred <- creds] + in Credentials [cred | (Just _, cred) <- orderedPairs] isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool isCredentialAllowed ver exts cred = @@ -606,10 +707,12 @@ isCredentialAllowed ver exts cred = -- ECDSA keys are tested against supported elliptic curves until TLS12 but -- not after. With TLS13, the curve is linked to the signature algorithm -- and client support is tested with signatureCompatible13. - p | ver < TLS13 = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of - Nothing -> const True - Just (NegotiatedGroups sg) -> (`elem` sg) - | otherwise = const True + 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. -- @@ -629,13 +732,14 @@ isCredentialAllowed ver exts cred = -- "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 + :: [ExtensionRaw] -> Credentials -> Credentials filterCredentialsWithHashSignatures exts = case withExt extensionID_SignatureAlgorithmsCert of Just (SignatureAlgorithmsCert sas) -> withAlgs sas Nothing -> case withExt extensionID_SignatureAlgorithms of - Nothing -> id + Nothing -> id Just (SignatureAlgorithms sas) -> withAlgs sas where withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello @@ -648,77 +752,115 @@ 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_DHE_RSA -> False + CipherKeyExchange_DHE_DSS -> False + CipherKeyExchange_ECDHE_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False - CipherKeyExchange_TLS13 -> False - _ -> True + 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 + :: 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 + 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 + 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 + 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 + -- 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 + 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 + 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 + 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) + 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 + 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 + :: 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 @@ -735,31 +877,35 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare 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) + 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 + 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 @@ -770,14 +916,14 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare 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) + | 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 () + Nothing -> return () Just (cred, hashSig) -> sendCertAndVerify cred hashSig let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs @@ -791,14 +937,14 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare serverApplicationSecret0 = triServer appKey applicationSecret = triBase appKey setTxState ctx usedHash usedCipher serverApplicationSecret0 - let appSecInfo = ApplicationSecretInfo (clientApplicationSecret0,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 - + 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 @@ -811,55 +957,65 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare 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 + 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 + 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 + 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) + 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 @@ -869,7 +1025,7 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare ciphers = supportedCiphers $ serverSupported sparams isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of Nothing -> False - Just c -> cipherHash c == cipherHash usedCipher + Just c -> cipherHash c == cipherHash usedCipher isSameVersion = chosenVersion == sessionVersion sdata isSameALPN = sessionALPN sdata == malpn isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required @@ -880,7 +1036,7 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare rtt0accept = serverEarlyDataSize sparams > 0 checkBinder _ Nothing = return [] - checkBinder earlySecret (Just (binder,n,tlen)) = do + checkBinder earlySecret (Just (binder, n, tlen)) = do binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing unless (binder `bytesEq` binder') $ decryptError "PSK binder validation failed" @@ -889,10 +1045,12 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare decideCredentialInfo allCreds = do cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts of - Nothing -> throwCore $ Error_Protocol "no signature_algorithms extension" MissingExtension + 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 + 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 @@ -910,9 +1068,10 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare sendServerHello keyShare srand extensions = do let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion - extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare - : ExtensionRaw extensionID_SupportedVersions selectedVersion - : extensions + extensions' = + ExtensionRaw extensionID_KeyShare serverKeyShare + : ExtensionRaw extensionID_SupportedVersions selectedVersion + : extensions helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions' loadPacket13 ctx $ Handshake13 [helo] @@ -935,28 +1094,37 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare 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 + -- 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) + | 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 + | 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 @@ -983,17 +1151,21 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare where tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize extensions = [ExtensionRaw extensionID_EarlyData tedi] - toSeconds i | i < 0 = 0 - | i > 604800 = 604800 - | otherwise = fromIntegral i + 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 -> [] + 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 + when (certCtx /= "") $ + throwCore $ + Error_Protocol "certificate request context MUST be empty" IllegalParameter -- fixme checking _ext clientCertificate sparams ctx certs return $ isNullCertificateChain certs @@ -1002,12 +1174,14 @@ doHandshake13 sparams ctx chosenVersion usedCipher exts usedHash clientKeyShare hashSize = hashDigestSize usedHash zero = B.replicate hashSize 0 -expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m () +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" + 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 + [] -> throwCore $ Error_Protocol "client certificate missing" HandshakeFailure + c : _ -> return $ certPubKey $ getCertificate c ver <- usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey @@ -1015,36 +1189,50 @@ expectCertVerify sparams ctx hChCc (CertVerify13 sigAlg sig) = liftIO $ do clientCertVerify sparams ctx certs verif expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") -helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO () +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 + 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 -> [] + 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 + [] -> + 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 + handshakeServer sparams ctx findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of - [] -> Nothing - v:_ -> Just v + [] -> 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. @@ -1054,70 +1242,80 @@ findHighestVersionFrom clientVersion allowedVersions = -- 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 + 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 + [] -> Nothing + v : _ -> Just v where svs = sortOn Down serverVersions cvs = sortOn Down $ filter (> SSL3) clientVersions -applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] +applicationProtocol + :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw] applicationProtocol ctx exts sparams = do -- ALPN (Application Layer Protocol Negotiation) - case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of + 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 + throwCore $ + Error_Protocol "no supported application protocols" NoApplicationProtocol usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto - return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation - (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] + return + [ ExtensionRaw + extensionID_ApplicationLayerProtocolNegotiation + (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) + ] _ -> return [] -credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm) +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 + 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' + :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l where forSigning cred = case credentialDigitalSignatureKey cred of - Nothing -> False + Nothing -> False Just pub -> pub `signatureCompatible13` sigAlg clientCertificate :: ServerParams -> Context -> CertificateChain -> IO () @@ -1127,9 +1325,13 @@ clientCertificate sparams ctx certs = do -- Call application callback to see whether the -- certificate chain is acceptable. -- - usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException + usage <- + liftIO $ + catchException + (onClientCertificate (serverHooks sparams) certs) + rejectOnException case usage of - CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs + CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use. @@ -1138,25 +1340,27 @@ clientCertificate sparams ctx certs = do 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 + 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 @@ -1178,7 +1382,9 @@ requestCertificateServer sparams ctx = do 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 + when (isNothing mCertReq) $ + throwCore $ + Error_Protocol "unknown certificate request context" DecodeError let certReq = fromJust "certReq" mCertReq -- fixme checking _ext @@ -1190,7 +1396,10 @@ postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = d (usedHash, _, level, applicationSecretN) <- getRxState ctx unless (level == CryptApplicationSecret) $ - throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError + throwCore $ + Error_Protocol + "tried post-handshake authentication without application traffic secret" + InternalError let expectFinished hChBeforeCf (Finished13 verifyData) = do checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData @@ -1201,13 +1410,18 @@ postHandshakeAuthServerWith sparams ctx h@(Certificate13 certCtx certs _ext) = d -- 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 - ] - + 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 + throwCore $ + Error_Protocol + "unexpected handshake message received in postHandshakeAuthServerWith" + UnexpectedMessage contextSync :: Context -> ServerState -> IO () contextSync ctx ctl = case ctxHandshakeSync ctx of diff --git a/core/Network/TLS/Handshake/Signature.hs b/core/Network/TLS/Handshake/Signature.hs index 84393e5e0..63255db48 100644 --- a/core/Network/TLS/Handshake/Signature.hs +++ b/core/Network/TLS/Handshake/Signature.hs @@ -1,38 +1,41 @@ {-# 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 +module Network.TLS.Handshake.Signature ( + createCertificateVerify, + checkCertificateVerify, + digitallySignDHParams, + digitallySignECDHParams, + digitallySignDHParamsVerify, + digitallySignECDHParamsVerify, + checkSupportedHashSignature, + certificateCompatible, + signatureCompatible, + signatureCompatible13, + hashSigToCertType, + signatureParams, + decryptError, +) where -import Network.TLS.Crypto 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, + generateCertificateVerify_SSL, + generateCertificateVerify_SSL_DSS, + ) +import Network.TLS.Parameters import Network.TLS.State -import Network.TLS.Handshake.State -import Network.TLS.Handshake.Key +import Network.TLS.Struct import Network.TLS.Util import Network.TLS.X509 @@ -45,26 +48,26 @@ decryptError msg = throwCore $ Error_Protocol msg DecryptError -- 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_DSS_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 _) (_, SignatureDSS) = 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 +78,7 @@ signatureCompatible13 (PubKeyEC ecPub) (h, SignatureECDSA) = 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 +99,57 @@ signatureCompatible13 pub hs = signatureCompatible pub hs -- @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 (_, SignatureDSS) = Just CertificateType_DSS_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 + :: 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 + (TLS12, Nothing) -> return False + (TLS12, Just hs) + | pubKey `signatureCompatible` hs -> doVerify + | otherwise -> return False + (_, Nothing) -> doVerify + (_, Just _) -> 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 + -> Maybe 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,73 +157,85 @@ type CertVerifyData = (SignatureParams, ByteString) -- 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 + :: 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) + 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) + _ -> + 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 + return $ buildVerifyData (signatureParams pubKey Nothing) msgs | otherwise = return (signatureParams pubKey hashSigAlg, msgs) signatureParams :: PubKey -> Maybe 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) + 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) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of - Nothing -> DSSParams + 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) + Just (_, SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" + Just (_, sigAlg) -> + error ("signature algorithm is incompatible with DSS: " ++ 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) + 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) 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) + 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) 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) + 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) signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") -signatureCreateWithCertVerifyData :: Context - -> Maybe HashAndSignatureAlgorithm - -> CertVerifyData - -> IO DigitallySigned +signatureCreateWithCertVerifyData + :: Context + -> Maybe HashAndSignatureAlgorithm + -> CertVerifyData + -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign @@ -228,72 +245,99 @@ signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = 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, 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" 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 + -> Maybe 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 + -> Maybe 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 + -> Maybe 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 "withClientAndServer : server random" <$> 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 + :: Context -> Maybe HashAndSignatureAlgorithm -> IO () +checkSupportedHashSignature _ Nothing = return () checkSupportedHashSignature ctx (Just hs) = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ let msg = "unsupported hash and signature algorithm: " ++ show hs diff --git a/core/Network/TLS/Handshake/State.hs b/core/Network/TLS/Handshake/State.hs index a8730da6b..2eb84147f 100644 --- a/core/Network/TLS/Handshake/State.hs +++ b/core/Network/TLS/Handshake/State.hs @@ -2,259 +2,272 @@ {-# 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 + addHandshakeMessage, + updateHandshakeDigest, + getHandshakeMessages, + getHandshakeMessagesRev, + getHandshakeDigest, + foldHandshakeDigest, + -- * master secret - , setMasterSecret - , setMasterSecretFromPre + setMasterSecret, + setMasterSecretFromPre, + -- * misc accessor - , getPendingCipher - , setServerHelloParameters - , setExtendedMasterSec - , getExtendedMasterSec - , setNegotiatedGroup - , getNegotiatedGroup - , setTLS13HandshakeMode - , getTLS13HandshakeMode - , setTLS13RTT0Status - , getTLS13RTT0Status - , setTLS13EarlySecret - , getTLS13EarlySecret - , setTLS13ResumptionSecret - , getTLS13ResumptionSecret - , setCCS13Sent - , getCCS13Sent - ) where + getPendingCipher, + setServerHelloParameters, + setExtendedMasterSec, + getExtendedMasterSec, + setNegotiatedGroup, + getNegotiatedGroup, + 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) + } + 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) + , 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) , 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. - - 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. --} + , 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. +-- +-- 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 + , 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 + } 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) getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey) -getLocalPublicPrivateKeys = fromJust "local public/private key" <$> gets (hksLocalPublicPrivateKeys . hstKeyState) +getLocalPublicPrivateKeys = + fromJust "local public/private key" + <$> 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 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 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 @@ -263,103 +276,104 @@ getGroupPrivate :: HandshakeM GroupPrivate getGroupPrivate = fromJust "server ECDH private" <$> 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 }) +setExtendedMasterSec b = modify (\hst -> hst{hstExtendedMasterSec = b}) getExtendedMasterSec :: HandshakeM Bool getExtendedMasterSec = gets hstExtendedMasterSec setNegotiatedGroup :: Group -> HandshakeM () -setNegotiatedGroup g = modify (\hst -> hst { hstNegotiatedGroup = Just g }) +setNegotiatedGroup g = modify (\hst -> hst{hstNegotiatedGroup = Just g}) getNegotiatedGroup :: HandshakeM (Maybe Group) getNegotiatedGroup = gets hstNegotiatedGroup -- | 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 @@ -369,7 +383,7 @@ getPendingCipher :: HandshakeM Cipher getPendingCipher = fromJust "pending cipher" <$> 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 +392,12 @@ getHandshakeMessagesRev :: HandshakeM [ByteString] getHandshakeMessagesRev = gets hstHandshakeMessages updateHandshakeDigest :: ByteString -> HandshakeM () -updateHandshakeDigest content = modify $ \hs -> hs - { hstHandshakeDigest = case hstHandshakeDigest hs of - HandshakeMessages bytes -> HandshakeMessages (content:bytes) - HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content } +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 +406,19 @@ foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM () foldHandshakeDigest hashAlg f = modify $ \hs -> case hstHandshakeDigest hs of HandshakeMessages bytes -> - let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes - !folded = f (hashFinal hashCtx) - in hs { hstHandshakeDigest = HandshakeMessages [folded] - , hstHandshakeMessages = [folded] - } + 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 +428,144 @@ getSessionHash = gets $ \hst -> 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 "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 -- | 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 + :: 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 secret <- if ems then get >>= genExtendedSecret else genSecret <$> get setMasterSecret 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 = + generateMasterSecret + ver + (fromJust "cipher" $ hstPendingCipher hst) + premasterSecret + (hstClientRandom hst) + (fromJust "server random" $ hstServerRandom hst) + genExtendedSecret hst = + generateExtendedMasterSec + ver + (fromJust "cipher" $ hstPendingCipher hst) + premasterSecret + <$> getSessionHash -- | Set master 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 + in hst + { hstMasterSecret = Just masterSecret , hstPendingTxState = Just pendingTx - , hstPendingRxState = Just pendingRx } + , hstPendingRxState = Just pendingRx + } -computeKeyBlock :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) +computeKeyBlock + :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst masterSecret ver cc = (pendingTx, pendingRx) - where cipher = fromJust "cipher" $ hstPendingCipher hst - keyblockSize = cipherKeyBlockSize cipher - - 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 - - (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = - fromJust "p6" $ partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) - - 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 } - - 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 - } - - orOnServer f g = if cc == ClientRole then f else g - - -setServerHelloParameters :: Version -- ^ chosen version - -> ServerRandom - -> Cipher - -> Compression - -> HandshakeM () + where + cipher = fromJust "cipher" $ hstPendingCipher hst + keyblockSize = cipherKeyBlockSize cipher + + 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 + + (cMACSecret, sMACSecret, cWriteKey, sWriteKey, cWriteIV, sWriteIV) = + fromJust "p6" $ + partition6 kb (digestSize, digestSize, keySize, keySize, ivSize, ivSize) + + 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} + + 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 + } + + orOnServer f g = if cc == ClientRole then f else g + +setServerHelloParameters + :: Version + -- ^ chosen version + -> ServerRandom + -> Cipher + -> Compression + -> HandshakeM () setServerHelloParameters ver sran cipher compression = do - modify $ \hst -> hst - { hstServerRandom = Just sran - , hstPendingCipher = Just cipher - , hstPendingCompression = compression - , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst - } - where hashAlg = getHash ver cipher - updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes - updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest" + 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/core/Network/TLS/Handshake/State13.hs b/core/Network/TLS/Handshake/State13.hs index e020a21ad..d6f1ffcc8 100644 --- a/core/Network/TLS/Handshake/State13.hs +++ b/core/Network/TLS/Handshake/State13.hs @@ -6,26 +6,26 @@ -- 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, + getTxState, + getRxState, + setTxState, + setRxState, + clearTxState, + clearRxState, + setHelloParameters13, + transcriptHash, + wrapAsMessageHash13, + PendingAction (..), + setPendingActions, + popPendingAction, +) where import Control.Concurrent.MVar import Control.Monad.State @@ -36,10 +36,10 @@ 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 @@ -49,9 +49,10 @@ getTxState ctx = getXState ctx ctxTxState getRxState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString) getRxState ctx = getXState ctx ctxRxState -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 @@ -78,37 +79,50 @@ setTxState = setXState ctxTxState BulkEncrypt setRxState :: TrafficSecret ty => Context -> Hash -> Cipher -> ty -> IO () setRxState = setXState ctxRxState 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 @@ -118,25 +132,29 @@ clearRxState = clearXState ctxRxState 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,17 +165,19 @@ wrapAsMessageHash13 = do 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 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) @@ -167,5 +187,5 @@ popPendingAction ctx = do let ref = ctxPendingActions 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/core/Network/TLS/Hooks.hs b/core/Network/TLS/Hooks.hs index 8ca05e3aa..35418d251 100644 --- a/core/Network/TLS/Hooks.hs +++ b/core/Network/TLS/Hooks.hs @@ -4,18 +4,17 @@ -- 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 +22,42 @@ import Data.Default.Class 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/core/Network/TLS/IO.hs b/core/Network/TLS/IO.hs index fad1f6450..2407b74af 100644 --- a/core/Network/TLS/IO.hs +++ b/core/Network/TLS/IO.hs @@ -1,25 +1,26 @@ {-# 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 ( + sendPacket, + sendPacket13, + recvPacket, + 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 @@ -49,15 +50,20 @@ sendPacket ctx@Context{ctxRecordLayer = recordLayer} pkt = do when (isNonNullAppData pkt) $ do withEmptyPacket <- readIORef $ ctxNeedEmptyPacket ctx when withEmptyPacket $ - writePacketBytes ctx recordLayer (AppData B.empty) >>= - recordSendBytes recordLayer + writePacketBytes ctx recordLayer (AppData B.empty) + >>= recordSendBytes recordLayer writePacketBytes ctx recordLayer pkt >>= recordSendBytes recordLayer - where isNonNullAppData (AppData b) = not $ B.null b - isNonNullAppData _ = False - -writePacketBytes :: Monoid bytes - => Context -> RecordLayer bytes -> Packet -> IO bytes + where + isNonNullAppData (AppData b) = not $ B.null b + isNonNullAppData _ = False + +writePacketBytes + :: Monoid bytes + => Context + -> RecordLayer bytes + -> Packet + -> IO bytes writePacketBytes ctx recordLayer pkt = do withLog ctx $ \logging -> loggingPacketSent logging (show pkt) edataToSend <- encodePacket ctx recordLayer pkt @@ -69,21 +75,26 @@ sendPacket13 :: Context -> Packet13 -> IO () sendPacket13 ctx@Context{ctxRecordLayer = recordLayer} pkt = writePacketBytes13 ctx recordLayer pkt >>= recordSendBytes recordLayer -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 + 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 @@ -91,35 +102,35 @@ recvPacket ctx@Context{ctxRecordLayer = recordLayer} = do let appDataOverhead = if hrr then 256 else 0 erecord <- recordRecv recordLayer compatSSLv2 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 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 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 ---------------------------------------------------------------- @@ -133,30 +144,31 @@ recvPacket13 ctx@Context{ctxRecordLayer = recordLayer} = do 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 ---------------------------------------------------------------- @@ -182,10 +194,11 @@ type Builder b = [b] -> [b] -- 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 -> (forall b. Monoid b => PacketFlightM b a) -> IO a runPacketFlight Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do ref <- newIORef id runReaderT f (recordLayer, ref) `finally` sendPendingFlight recordLayer ref diff --git a/core/Network/TLS/Imports.hs b/core/Network/TLS/Imports.hs index 6910476bd..a5c9f1423 100644 --- a/core/Network/TLS/Imports.hs +++ b/core/Network/TLS/Imports.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} -- | @@ -7,54 +6,39 @@ -- 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, + MonadFail, + 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.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/core/Network/TLS/Internal.hs b/core/Network/TLS/Internal.hs index 16e166e04..7f3ed53c3 100644 --- a/core/Network/TLS/Internal.hs +++ b/core/Network/TLS/Internal.hs @@ -1,28 +1,28 @@ {-# 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 +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 +import Network.TLS.Core (recvPacket, sendPacket) 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.Wire -import Network.TLS.Core (sendPacket, recvPacket) diff --git a/core/Network/TLS/KeySchedule.hs b/core/Network/TLS/KeySchedule.hs index 759160382..b957c932c 100644 --- a/core/Network/TLS/KeySchedule.hs +++ b/core/Network/TLS/KeySchedule.hs @@ -1,35 +1,35 @@ {-# 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 +43,13 @@ deriveSecret h secret label hashedMsgs = -- | @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 +58,7 @@ hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen 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/core/Network/TLS/MAC.hs b/core/Network/TLS/MAC.hs index a206a1993..c8b07f935 100644 --- a/core/Network/TLS/MAC.hs +++ b/core/Network/TLS/MAC.hs @@ -4,59 +4,62 @@ -- 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' + 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 +70,10 @@ prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len 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/core/Network/TLS/Measurement.hs b/core/Network/TLS/Measurement.hs index d9c3643b5..969ff6287 100644 --- a/core/Network/TLS/Measurement.hs +++ b/core/Network/TLS/Measurement.hs @@ -4,43 +4,47 @@ -- 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/core/Network/TLS/Packet.hs b/core/Network/TLS/Packet.hs index e6927b4f3..fed3b6ea6 100644 --- a/core/Network/TLS/Packet.hs +++ b/core/Network/TLS/Packet.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Network.TLS.Packet -- License : BSD-style @@ -8,87 +9,90 @@ -- -- 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 - ( +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, + decodeDeprecatedHeaderLength, + decodeDeprecatedHeader, + encodeHeader, + encodeHeaderNoVer, -- use for SSL3 -- * marshall functions for alert messages - , decodeAlert - , decodeAlerts - , encodeAlerts + decodeAlert, + decodeAlerts, + encodeAlerts, -- * marshall functions for handshake messages - , decodeHandshakeRecord - , decodeHandshake - , decodeDeprecatedHandshake - , encodeHandshake - , encodeHandshakeHeader - , encodeHandshakeContent + decodeHandshakeRecord, + decodeHandshake, + decodeDeprecatedHandshake, + encodeHandshake, + encodeHandshakeHeader, + encodeHandshakeContent, -- * marshall functions for change cipher spec message - , decodeChangeCipherSpec - , encodeChangeCipherSpec - - , decodePreMasterSecret - , encodePreMasterSecret - , encodeSignedDHParams - , encodeSignedECDHParams - - , decodeReallyServerKeyXchgAlgorithmData + decodeChangeCipherSpec, + encodeChangeCipherSpec, + decodePreMasterSecret, + encodePreMasterSecret, + encodeSignedDHParams, + encodeSignedECDHParams, + decodeReallyServerKeyXchgAlgorithmData, -- * generate things for packet content - , generateMasterSecret - , generateExtendedMasterSec - , generateKeyBlock - , generateClientFinished - , generateServerFinished - - , generateCertificateVerify_SSL - , generateCertificateVerify_SSL_DSS + generateMasterSecret, + generateExtendedMasterSec, + generateKeyBlock, + generateClientFinished, + generateServerFinished, + generateCertificateVerify_SSL, + generateCertificateVerify_SSL_DSS, -- * for extensions parsing - , getSignatureHashAlgorithm - , putSignatureHashAlgorithm - , getBinaryVersion - , putBinaryVersion - , getClientRandom32 - , putClientRandom32 - , getServerRandom32 - , putServerRandom32 - , getExtensions - , putExtension - , getSession - , putSession - , putDNames - , getDNames - ) where - -import Network.TLS.Imports -import Network.TLS.Struct -import Network.TLS.Wire + getSignatureHashAlgorithm, + putSignatureHashAlgorithm, + getBinaryVersion, + putBinaryVersion, + getClientRandom32, + putClientRandom32, + getServerRandom32, + putServerRandom32, + getExtensions, + putExtension, + getSession, + putSession, + putDNames, + getDNames, +) where + +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as B (convert) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.X509 ( + CertificateChainRaw (..), + decodeCertificateChain, + encodeCertificateChain, + ) import Network.TLS.Cap -import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) +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 @@ -97,7 +101,7 @@ getVersion = do minor <- getWord8 case verOfNum (major, minor) of Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) - Just v -> return v + Just v -> return v getBinaryVersion :: Get (Maybe Version) getBinaryVersion = do @@ -107,14 +111,15 @@ getBinaryVersion = do putBinaryVersion :: Version -> Put putBinaryVersion ver = putWord8 major >> putWord8 minor - where (major, minor) = numericalVer ver + where + (major, minor) = numericalVer ver getHeaderType :: Get ProtocolType getHeaderType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid header type: " ++ show ty) - Just t -> return t + Just t -> return t putHeaderType :: ProtocolType -> Put putHeaderType = putWord8 . valOfType @@ -124,7 +129,7 @@ getHandshakeType = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid handshake type: " ++ show ty) - Just t -> return t + Just t -> return t {- - decode and encode headers @@ -144,11 +149,13 @@ decodeDeprecatedHeader size = encodeHeader :: Header -> ByteString encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) - {- FIXME check len <= 2^14 -} + +{- FIXME check len <= 2^14 -} 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 @@ -159,91 +166,97 @@ decodeAlert = do 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" + (Nothing, _) -> fail "cannot decode alert level" + (_, Nothing) -> fail "cannot decode alert description" 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 (valOfType al) >> putWord8 (valOfType 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 -> decodeCertificates + HandshakeType_ServerKeyXchg -> decodeServerKeyXchg cp + HandshakeType_CertRequest -> decodeCertRequest cp HandshakeType_ServerHelloDone -> decodeServerHelloDone - HandshakeType_CertVerify -> decodeCertVerify cp - HandshakeType_ClientKeyXchg -> decodeClientKeyXchg cp - HandshakeType_Finished -> decodeFinished + 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 + 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 decodeHelloRequest :: Get Handshake decodeHelloRequest = return HelloRequest decodeClientHello :: Get Handshake decodeClientHello = do - ver <- getVersion - random <- getClientRandom32 - session <- getSession - ciphers <- getWords16 + ver <- getVersion + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 compressions <- getWords8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 + r <- remaining + exts <- + if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else do - rest <- remaining - _ <- getBytes rest - return [] + rest <- remaining + _ <- getBytes rest + return [] return $ ClientHello ver random session ciphers compressions exts Nothing decodeServerHello :: Get Handshake decodeServerHello = do - ver <- getVersion - random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 + ver <- getVersion + random <- getServerRandom32 + session <- getSession + cipherid <- getWord16 compressionid <- getWord8 - r <- remaining - exts <- if hasHelloExtensions ver && r > 0 + r <- remaining + exts <- + if hasHelloExtensions ver && r > 0 then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts @@ -253,11 +266,14 @@ decodeServerHelloDone = return ServerHelloDone decodeCertificates :: Get Handshake decodeCertificates = do - certsRaw <- CertificateChainRaw <$> (getWord24 >>= \len -> getList (fromIntegral len) getCertRaw) + 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 $ Certificates cc + where + getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) decodeFinished :: Get Handshake decodeFinished = Finished <$> (remaining >>= getBytes) @@ -266,11 +282,14 @@ 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 + sigHashAlgs <- + if cParamsVersion cp >= TLS12 + then Just <$> (getWord16 >>= getSignatureHashAlgorithms) + else return Nothing 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 +302,29 @@ getDNames = do 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_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 decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = getServerDHParams @@ -311,56 +333,59 @@ decodeServerKeyXchg_DH = getServerDHParams -- decodeServerKeyXchg_ECDH :: Get ServerECDHParams decodeServerKeyXchg_RSA :: Get ServerRSAParams -decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus - <*> getInteger16 -- exponent - -decodeServerKeyXchgAlgorithmData :: Version - -> CipherKeyExchangeType - -> Get ServerKeyXchgAlgorithmData +decodeServerKeyXchg_RSA = + ServerRSAParams + <$> getInteger16 -- modulus + <*> getInteger16 -- exponent + +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_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 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 + 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 ] + _ -> 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 - encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do putBytes deprecated encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do @@ -371,7 +396,6 @@ encodeHandshakeContent (ClientHello version random session cipherIDs compression putWords8 compressionIDs putExtensions exts return () - encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do putBinaryVersion version putServerRandom32 random @@ -380,39 +404,36 @@ encodeHandshakeContent (ServerHello version random session cipherid compressionI putWord8 compressionID putExtensions exts return () - encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) - where (CertificateChainRaw certs) = encodeCertificateChain cc - + where + (CertificateChainRaw certs) = encodeCertificateChain cc encodeHandshakeContent (ClientKeyXchg ckx) = do case ckx of CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster - CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic - CKX_ECDH bytes -> putOpaque8 bytes - + CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic + CKX_ECDH bytes -> putOpaque8 bytes encodeHandshakeContent (ServerKeyXchg skg) = case skg of - SKX_RSA _ -> error "encodeHandshakeContent SKX_RSA not implemented" - SKX_DH_Anon params -> putServerDHParams params + SKX_RSA _ -> error "encodeHandshakeContent 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_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 () + 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 + Just l -> + putWords16 $ + map (\(x, y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l putDNames certAuthorities - encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned - encodeHandshakeContent (Finished opaque) = putBytes opaque ------------------------------------------------------------ @@ -423,7 +444,7 @@ putDNames dnames = do 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,15 +472,15 @@ getSession :: Get Session 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 extdatalen <- getWord16 @@ -478,47 +499,50 @@ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" - return (h,s) + return (h, s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put -putSignatureHashAlgorithm (h,s) = +putSignatureHashAlgorithm (h, s) = putWord8 (valOfType h) >> putWord8 (valOfType 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 + 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 + 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 _ -> 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 + putWord8 3 -- ECParameters ECCurveType + putWord16 $ fromEnumSafe16 grp -- ECParameters NamedCurve putOpaque8 $ encodeGroupPublic grppub -- ECPoint getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned ver - | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm) - <*> getOpaque16 - | otherwise = DigitallySigned Nothing <$> getOpaque16 + | ver >= TLS12 = + DigitallySigned + <$> (Just <$> getSignatureHashAlgorithm) + <*> getOpaque16 + | otherwise = DigitallySigned Nothing <$> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned mhash sig) = @@ -538,8 +562,9 @@ encodeChangeCipherSpec = runPut (putWord8 1) -- rsa pre master secret decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString) -decodePreMasterSecret = runGetErr "pre-master-secret" $ - (,) <$> getVersion <*> getBytes 46 +decodePreMasterSecret = + runGetErr "pre-master-secret" $ + (,) <$> getVersion <*> getBytes 46 encodePreMasterSecret :: Version -> ByteString -> ByteString encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) @@ -548,13 +573,15 @@ encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putByt -- 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,92 +596,120 @@ getPRF ver ciph | 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 + :: 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 + 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 + 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 - -generateExtendedMasterSec :: ByteArrayAccess preMaster - => Version - -> Cipher - -> preMaster - -> ByteString - -> ByteString +generateMasterSecret v c = generateMasterSecret_TLS $ getPRF v c + +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 + where + seed = B.append "extended master secret" sessionHash -generateKeyBlock_TLS :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString +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 ] + prf mastersecret seed kbsize + where + seed = B.concat ["key expansion", s, c] -generateKeyBlock_SSL :: ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString +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 :: Version - -> Cipher - -> ClientRandom - -> ServerRandom - -> ByteString - -> Int - -> ByteString + 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 + :: Version + -> Cipher + -> ClientRandom + -> ServerRandom + -> ByteString + -> Int + -> ByteString generateKeyBlock SSL2 _ = generateKeyBlock_SSL generateKeyBlock SSL3 _ = generateKeyBlock_SSL -generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c +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 ] + 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 + 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 + | 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" + | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" {- returns *output* after final MD5/SHA1 -} generateCertificateVerify_SSL :: ByteString -> HashCtx -> ByteString @@ -663,24 +718,31 @@ generateCertificateVerify_SSL = generateFinished_SSL "" {- returns *input* before final SHA1 -} generateCertificateVerify_SSL_DSS :: ByteString -> HashCtx -> ByteString generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash - where toHash = B.concat [ mastersecret, pad2, sha1left ] + where + toHash = B.concat [mastersecret, pad2, sha1left] - sha1left = hashFinal $ flip hashUpdate pad1 - $ hashUpdate hashctx mastersecret - pad2 = B.replicate 40 0x5c - pad1 = B.replicate 40 0x36 + sha1left = + hashFinal $ + flip hashUpdate pad1 $ + hashUpdate hashctx mastersecret + pad2 = B.replicate 40 0x5c + pad1 = B.replicate 40 0x36 -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 +fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing") +fromJustM _ (Just x) = return x diff --git a/core/Network/TLS/Packet13.hs b/core/Network/TLS/Packet13.hs index 89fc21088..98c009cf6 100644 --- a/core/Network/TLS/Packet13.hs +++ b/core/Network/TLS/Packet13.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Packet13 @@ -8,23 +8,26 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Packet13 - ( encodeHandshake13 - , getHandshakeType13 - , decodeHandshakeRecord13 - , decodeHandshake13 - , decodeHandshakes13 - ) where +module Network.TLS.Packet13 ( + encodeHandshake13, + getHandshakeType13, + decodeHandshakeRecord13, + decodeHandshake13, + decodeHandshakes13, +) where import qualified Data.ByteString as B +import Data.X509 ( + 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.Wire -import Network.TLS.Imports -import Data.X509 (CertificateChainRaw(..), encodeCertificateChain, decodeCertificateChain) -import Network.TLS.ErrT encodeHandshake13 :: Handshake13 -> ByteString encodeHandshake13 hdsk = pkt @@ -63,7 +66,7 @@ encodeHandshake13' (Certificate13 reqctx cc ess) = runPut $ do putOpaque24 (runPut $ mapM_ putCert $ zip certs ess) where CertificateChainRaw certs = encodeCertificateChain cc - putCert (certRaw,exts) = do + putCert (certRaw, exts) = do putOpaque24 certRaw putExtensions exts encodeHandshake13' (CertVerify13 hs signature) = runPut $ do @@ -78,7 +81,7 @@ encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ 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 ty len = runPut $ do @@ -87,14 +90,14 @@ encodeHandshakeHeader13 ty len = runPut $ do 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 + 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 @@ -102,54 +105,56 @@ getHandshakeType13 = do ty <- getWord8 case valToType ty of Nothing -> fail ("invalid handshake type: " ++ show ty) - Just t -> return t + Just t -> return t decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do - ty <- getHandshakeType13 + ty <- getHandshakeType13 content <- getOpaque24 return (ty, content) -decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 +decodeHandshake13 + :: HandshakeType13 -> ByteString -> Either TLSError Handshake13 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of - HandshakeType_ClientHello13 -> decodeClientHello13 - HandshakeType_ServerHello13 -> decodeServerHello13 - HandshakeType_Finished13 -> decodeFinished13 + 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 + 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 + random <- getClientRandom32 + session <- getSession + ciphers <- getWords16 + _comp <- getWords8 + exts <- fromIntegral <$> getWord16 >>= getExtensions return $ ClientHello13 ver random session ciphers exts decodeServerHello13 :: Get Handshake13 decodeServerHello13 = do Just _ver <- getBinaryVersion - random <- getServerRandom32 - session <- getSession - cipherid <- getWord16 - _comp <- getWord8 - exts <- fromIntegral <$> getWord16 >>= getExtensions + 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 +170,7 @@ decodeCertificate13 = do (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 +184,12 @@ decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16 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 diff --git a/core/Network/TLS/Parameters.hs b/core/Network/TLS/Parameters.hs index fc6466357..610a05399 100644 --- a/core/Network/TLS/Parameters.hs +++ b/core/Network/TLS/Parameters.hs @@ -4,79 +4,78 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Parameters - ( - ClientParams(..) - , ServerParams(..) - , CommonParams - , DebugParams(..) - , ClientHooks(..) - , OnCertificateRequest - , OnServerCertificate - , ServerHooks(..) - , Supported(..) - , Shared(..) +module Network.TLS.Parameters ( + ClientParams (..), + ServerParams (..), + CommonParams, + DebugParams (..), + ClientHooks (..), + OnCertificateRequest, + OnServerCertificate, + ServerHooks (..), + Supported (..), + Shared (..), + -- * special default - , defaultParamsClient + defaultParamsClient, + -- * Parameters - , MaxFragmentEnum(..) - , EMSMode(..) - , GroupUsage(..) - , CertificateUsage(..) - , CertificateRejectReason(..) - ) where + 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 qualified Data.ByteString as B +import Data.Default.Class 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.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 Data.Default.Class -import qualified Data.ByteString as B - +import Network.TLS.X509 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 + { 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 () - -- | Force to choose this version in the server side. - -- - -- Default: 'Nothing' + -- ^ 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 - -- | Printing master keys. - -- - -- Default: no printing - , debugKeyLogger :: String -> IO () + -- ^ Force to choose this version in the server side. + -- + -- Default: 'Nothing' + , debugKeyLogger :: String -> IO () + -- ^ Printing master keys. + -- + -- Default: no printing } defaultDebugParams :: DebugParams -defaultDebugParams = DebugParams - { debugSeed = Nothing - , debugPrintSeed = const (return ()) - , debugVersionForced = Nothing - , debugKeyLogger = \_ -> return () - } +defaultDebugParams = + DebugParams + { debugSeed = Nothing + , debugPrintSeed = const (return ()) + , debugVersionForced = Nothing + , debugKeyLogger = \_ -> return () + } instance Show DebugParams where show _ = "DebugParams" @@ -84,465 +83,489 @@ 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) + { 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'. + , clientEarlyData :: Maybe ByteString + -- ^ 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' + } + 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 - } +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: '[]' + { serverWantClientCert :: Bool + -- ^ Request a certificate from client. + -- + -- Default: 'False' , 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) + -- ^ 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). The default lifetime + -- is 86400 seconds (1 day). + -- + -- Default: 86400 (one day) + } + deriving (Show) defaultParamsServer :: ServerParams -defaultParamsServer = ServerParams - { serverWantClientCert = False - , serverCACertificates = [] - , serverDHEParams = Nothing - , serverHooks = def - , serverShared = def - , serverSupported = def - , serverDebug = defaultDebugParams - , serverEarlyDataSize = 0 - , serverTicketLifetime = 86400 - } +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) - -- ] - -- @ + { 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,TLS11,TLS10]@ + , 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] - -- | 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' + -- ^ 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) + -- ] + -- @ , 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' + -- ^ 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 - -- | 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) + -- ^ 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' + , supportedExtendedMasterSec :: EMSMode + -- ^ 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' + , 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 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) + = -- | Extended Master Secret is not used + NoEMS + | -- | Extended Master Secret is allowed + AllowEMS + | -- | Extended Master Secret is required + RequireEMS + 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] - } +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'. + { 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 - -- | 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: @[]@ + -- ^ 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 + 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) +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 + | 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 + | 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 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] +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' + { 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 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. + -- ^ 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 - } +defaultClientHooks = + ClientHooks + { onCertificateRequest = \_ -> return Nothing + , onServerCertificate = validateDefault + , onSuggestALPN = return Nothing + , onCustomFFDHEGroup = defaultGroupUsage 1024 + } instance Show ClientHooks where show _ = "ClientHooks" @@ -551,84 +574,82 @@ instance Default ClientHooks where -- | 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' + { 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 - - -- | 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' + -- ^ 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 . id' } 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 - } +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 + } instance Show ServerHooks where show _ = "ServerHooks" diff --git a/core/Network/TLS/PostHandshake.hs b/core/Network/TLS/PostHandshake.hs index ee76c0862..371f7cd9a 100644 --- a/core/Network/TLS/PostHandshake.hs +++ b/core/Network/TLS/PostHandshake.hs @@ -4,21 +4,20 @@ -- 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 @@ -28,12 +27,16 @@ import Control.Monad.State.Strict -- post-handshake authentication. requestCertificate :: MonadIO m => Context -> m Bool requestCertificate ctx = - liftIO $ withWriteLock ctx $ - checkValid ctx >> ctxDoRequestCertificate ctx ctx + liftIO $ + withWriteLock ctx $ + checkValid ctx >> ctxDoRequestCertificate 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 ctx hs = - liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoPostHandshakeAuthWith ctx ctx hs + liftIO $ + withWriteLock ctx $ + handleException ctx $ + ctxDoPostHandshakeAuthWith ctx ctx hs diff --git a/core/Network/TLS/QUIC.hs b/core/Network/TLS/QUIC.hs index ac68a77ee..99e78ecfc 100644 --- a/core/Network/TLS/QUIC.hs +++ b/core/Network/TLS/QUIC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Network.TLS.QUIC -- License : BSD-style @@ -25,47 +26,54 @@ -- 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_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 @@ -80,7 +88,7 @@ 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,68 +98,69 @@ import Network.TLS.Types 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 @@ -164,13 +173,15 @@ getRxLevel ctx = do (_, _, level, _) <- getRxState ctx return level -newRecordLayer :: Context -> QUICCallbacks - -> RecordLayer [(CryptLevel, ByteString)] +newRecordLayer + :: Context + -> QUICCallbacks + -> RecordLayer [(CryptLevel, ByteString)] newRecordLayer ctx callbacks = newTransparentRecordLayer get send recv where - get = getTxLevel ctx - send = quicSend callbacks - recv = getRxLevel ctx >>= quicRecv callbacks + get = getTxLevel ctx + send = quicSend callbacks + recv = 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,11 +189,12 @@ newRecordLayer ctx callbacks = newTransparentRecordLayer get send recv tlsQUICClient :: ClientParams -> QUICCallbacks -> IO () tlsQUICClient cparams callbacks = do ctx0 <- contextNew nullBackend cparams - let ctx1 = ctx0 - { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ()) - , ctxFragmentSize = Nothing - , ctxQUICMode = True - } + let ctx1 = + ctx0 + { ctxHandshakeSync = HandshakeSync sync (\_ _ -> return ()) + , ctxFragmentSize = Nothing + , ctxQUICMode = True + } rl = newRecordLayer ctx2 callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 @@ -196,7 +208,8 @@ tlsQUICClient cparams callbacks = do 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,11 +219,12 @@ tlsQUICClient cparams callbacks = do tlsQUICServer :: ServerParams -> QUICCallbacks -> IO () tlsQUICServer sparams callbacks = do ctx0 <- contextNew nullBackend sparams - let ctx1 = ctx0 - { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync - , ctxFragmentSize = Nothing - , ctxQUICMode = True - } + let ctx1 = + ctx0 + { ctxHandshakeSync = HandshakeSync (\_ _ -> return ()) sync + , ctxFragmentSize = Nothing + , ctxQUICMode = True + } rl = newRecordLayer ctx2 callbacks ctx2 = updateRecordLayer rl ctx1 handshake ctx2 @@ -219,7 +233,8 @@ tlsQUICServer sparams callbacks = do 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 +242,10 @@ tlsQUICServer sparams callbacks = do 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 == extensionID_QuicTransportParameters || eid == 0xffa5 -- to be deleted + ) -- | Can be used by callbacks to signal an unexpected condition. This will then -- generate an "internal_error" alert in the TLS stack. @@ -248,14 +266,16 @@ toAlertDescription :: Word8 -> Maybe AlertDescription toAlertDescription = valToType 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/core/Network/TLS/RNG.hs b/core/Network/TLS/RNG.hs index eba1a8d30..e085a529b 100644 --- a/core/Network/TLS/RNG.hs +++ b/core/Network/TLS/RNG.hs @@ -1,18 +1,19 @@ {-# 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 +import Crypto.Random.Types newtype StateRNG = StateRNG ChaChaDRG deriving (DRG) @@ -20,9 +21,10 @@ newtype StateRNG = StateRNG ChaChaDRG 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/core/Network/TLS/Receiving.hs b/core/Network/TLS/Receiving.hs index d5b0eb0aa..d20df9fb4 100644 --- a/core/Network/TLS/Receiving.hs +++ b/core/Network/TLS/Receiving.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | -- Module : Network.TLS.Receiving -- License : BSD-style @@ -7,13 +9,10 @@ -- -- 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 Network.TLS.Cipher import Network.TLS.Context.Internal @@ -33,40 +32,40 @@ 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 - + 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 @@ -75,7 +74,7 @@ processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = switchRxEncryption :: Context -> IO () switchRxEncryption ctx = usingHState ctx (gets hstPendingRxState) >>= \rx -> - liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) + liftIO $ modifyMVar_ (ctxRxState ctx) (\_ -> return $ fromJust "rx-state" rx) ---------------------------------------------------------------- @@ -85,18 +84,20 @@ processPacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ Ap 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 + 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") diff --git a/core/Network/TLS/Record.hs b/core/Network/TLS/Record.hs index d5581c1d1..b57cfde33 100644 --- a/core/Network/TLS/Record.hs +++ b/core/Network/TLS/Record.hs @@ -10,33 +10,35 @@ -- 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(..) +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/core/Network/TLS/Record/Disengage.hs b/core/Network/TLS/Record/Disengage.hs index 203130e0e..126025613 100644 --- a/core/Network/TLS/Record/Disengage.hs +++ b/core/Network/TLS/Record/Disengage.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | -- Module : Network.TLS.Record.Disengage -- License : BSD-style @@ -11,30 +13,27 @@ -- 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 Network.TLS.Struct -import Network.TLS.ErrT +import Crypto.Cipher.Types (AuthTag (..)) +import qualified Data.ByteArray as B (convert, xor) +import qualified Data.ByteString as B import Network.TLS.Cap -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.Crypto +import Network.TLS.ErrT +import Network.TLS.Imports +import Network.TLS.Packet +import Network.TLS.Record.State +import Network.TLS.Record.Types +import Network.TLS.Struct import Network.TLS.Util import Network.TLS.Wire -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,30 +47,31 @@ decryptRecord record@(Record ct ver fragment) = do 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) -> + Nothing -> Left $ unknownContentType13 (0 :: Word8) + Just (bytes, c) -> case valToType c of Nothing -> Left $ unknownContentType13 c Just ct @@ -79,15 +79,15 @@ unInnerPlaintext inner = Left ("empty " ++ show ct ++ " record disallowed") | otherwise -> Right (ct, 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 @@ -96,106 +96,123 @@ getCipherData (Record pt ver _) cdata = do -- 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 + Nothing -> return True Just (pad, blksz) -> do cver <- getRecordVersion let b = B.length pad - 1 - return $ if cver < TLS10 - then b < blksz - else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad + return $ + if cver < TLS10 + then b < blksz + else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad unless (macValid &&! paddingValid) $ - throwError $ Error_Protocol "bad record mac" BadRecordMac + throwError $ + Error_Protocol "bad record mac" 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 - - {- 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' } } - - let paddinglength = fromIntegral (B.last content') + 1 - let contentlen = B.length content' - paddinglength - macSize - (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) - getCipherData record CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Just (padding, blockSize) - } - - decryptOf (BulkStateStream (BulkStream decryptF)) = do - -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < macSize) sanityCheckError - - let (content', bulkStream') = decryptF econtent - {- update Ctx -} - let contentlen = B.length content' - macSize - (content, mac) <- get2i content' (contentlen, macSize) - modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } } - getCipherData record CipherData - { cipherDataContent = content - , cipherDataMAC = Just mac - , cipherDataPadding = Nothing - } - - decryptOf (BulkStateAEAD decryptF) = do - let authTagLen = bulkAuthTagLen bulk - nonceExpLen = bulkExplicitIV bulk - cipherLen = econtentLen - authTagLen - nonceExpLen - - -- check if we have enough bytes to cover the minimum for this cipher - when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError - - (enonce, econtent', authTag) <- get3o econtent (nonceExpLen, cipherLen, authTagLen) - let encodedSeq = encodeWord64 $ msSequence $ stMacState tst - iv = cstIV (stCryptState tst) - ivlen = B.length iv - Header typ v _ = recordToHeader record - hdrLen = if ver >= TLS13 then econtentLen else cipherLen - hdr = Header typ v $ fromIntegral hdrLen - ad | ver >= TLS13 = encodeHeader hdr - | otherwise = B.concat [ encodedSeq, encodeHeader hdr ] - sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq - nonce | nonceExpLen == 0 = B.xor iv sqnc - | otherwise = iv `B.append` enonce - (content, authTag2) = decryptF nonce econtent' ad - - when (AuthTag (B.convert authTag) /= authTag2) $ - throwError $ Error_Protocol "bad record mac" BadRecordMac - - modify incrRecordState - return content - - decryptOf BulkStateUninitialized = - throwError $ Error_Protocol "decrypt state uninitialized" InternalError - - -- handling of outer format can report errors with Error_Packet - get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls - get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) - - -- all format errors related to decrypted content are reported - -- externally as integrity failures, i.e. BadRecordMac - get3i s ls = maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ partition3 s ls - get2i s (d1,d2) = get3i s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2) + 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 + + {- 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'}} + + let paddinglength = fromIntegral (B.last content') + 1 + let contentlen = B.length content' - paddinglength - macSize + (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) + getCipherData + record + CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Just (padding, blockSize) + } + decryptOf (BulkStateStream (BulkStream decryptF)) = do + -- check if we have enough bytes to cover the minimum for this cipher + when (econtentLen < macSize) sanityCheckError + + let (content', bulkStream') = decryptF econtent + {- update Ctx -} + let contentlen = B.length content' - macSize + (content, mac) <- get2i content' (contentlen, macSize) + modify $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}} + getCipherData + record + CipherData + { cipherDataContent = content + , cipherDataMAC = Just mac + , cipherDataPadding = Nothing + } + decryptOf (BulkStateAEAD decryptF) = do + let authTagLen = bulkAuthTagLen bulk + nonceExpLen = bulkExplicitIV bulk + cipherLen = econtentLen - authTagLen - nonceExpLen + + -- check if we have enough bytes to cover the minimum for this cipher + when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError + + (enonce, econtent', authTag) <- + get3o econtent (nonceExpLen, cipherLen, authTagLen) + let encodedSeq = encodeWord64 $ msSequence $ stMacState tst + iv = cstIV (stCryptState tst) + ivlen = B.length iv + Header typ v _ = recordToHeader record + hdrLen = if ver >= TLS13 then econtentLen else cipherLen + hdr = Header typ v $ fromIntegral hdrLen + ad + | ver >= TLS13 = encodeHeader hdr + | otherwise = B.concat [encodedSeq, encodeHeader hdr] + sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq + nonce + | nonceExpLen == 0 = B.xor iv sqnc + | otherwise = iv `B.append` enonce + (content, authTag2) = decryptF nonce econtent' ad + + when (AuthTag (B.convert authTag) /= authTag2) $ + throwError $ + Error_Protocol "bad record mac" BadRecordMac + + modify incrRecordState + return content + decryptOf BulkStateUninitialized = + throwError $ Error_Protocol "decrypt state uninitialized" InternalError + + -- handling of outer format can report errors with Error_Packet + get3o s ls = + maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls + get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) + + -- all format errors related to decrypted content are reported + -- externally as integrity failures, i.e. BadRecordMac + get3i s ls = + maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ + partition3 s ls + get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) diff --git a/core/Network/TLS/Record/Engage.hs b/core/Network/TLS/Record/Engage.hs index b6ed393a8..ff246d3e8 100644 --- a/core/Network/TLS/Record/Engage.hs +++ b/core/Network/TLS/Record/Engage.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + -- | -- Module : Network.TLS.Record.Engage -- License : BSD-style @@ -11,26 +13,24 @@ -- 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 qualified Data.ByteArray as B (convert, xor) +import qualified Data.ByteString as B import Network.TLS.Cap -import Network.TLS.Record.State -import Network.TLS.Record.Types import Network.TLS.Cipher import Network.TLS.Compression -import Network.TLS.Wire +import Network.TLS.Imports import Network.TLS.Packet +import Network.TLS.Record.State +import Network.TLS.Record.Types import Network.TLS.Struct -import Network.TLS.Imports -import qualified Data.ByteString as B -import qualified Data.ByteArray as B (convert, xor) +import Network.TLS.Wire engageRecord :: Record Plaintext -> RecordM (Record Ciphertext) engageRecord = compressRecord >=> encryptRecord @@ -58,9 +58,9 @@ encryptRecord record@(Record ct ver fragment) = do 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 @@ -71,16 +71,16 @@ innerPlaintext ct bytes = runPut $ do 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 @@ -93,52 +93,58 @@ encryptBlock encryptF content bulk = do 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] + then return $ B.concat [cstIV cst, e] else do - modify $ \tstate -> tstate { stCryptState = cst { cstIV = iv' } } + modify $ \tstate -> tstate{stCryptState = cst{cstIV = iv'}} return 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/core/Network/TLS/Record/Layer.hs b/core/Network/TLS/Record/Layer.hs index c3ca3d484..65a77bdfc 100644 --- a/core/Network/TLS/Record/Layer.hs +++ b/core/Network/TLS/Record/Layer.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Record.Layer ( - RecordLayer(..) - , newTransparentRecordLayer - ) where + RecordLayer (..), + newTransparentRecordLayer, +) where import Network.TLS.Imports import Network.TLS.Record @@ -11,30 +11,33 @@ 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 - } - -transparentEncodeRecord :: IO ann -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)]) +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 + } + +transparentEncodeRecord + :: IO ann -> Record Plaintext -> IO (Either TLSError [(ann, ByteString)]) transparentEncodeRecord _ (Record ProtocolType_ChangeCipherSpec _ _) = return $ Right [] transparentEncodeRecord _ (Record ProtocolType_Alert _ _) = @@ -44,20 +47,21 @@ transparentEncodeRecord _ (Record ProtocolType_Alert _ _) = transparentEncodeRecord get (Record _ _ frag) = get >>= \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 ()) -> [(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 + :: IO (Either TLSError ByteString) + -> IO (Either TLSError (Record Plaintext)) transparentRecvRecord recv = fmap (Record ProtocolType_Handshake TLS12 . fragmentPlaintext) <$> recv 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/core/Network/TLS/Record/Reading.hs b/core/Network/TLS/Record/Reading.hs index 2744e4253..30cb55f8e 100644 --- a/core/Network/TLS/Record/Reading.hs +++ b/core/Network/TLS/Record/Reading.hs @@ -6,11 +6,10 @@ -- Portability : unknown -- -- TLS record layer in Rx direction --- -module Network.TLS.Record.Reading - ( recvRecord - , recvRecord13 - ) where +module Network.TLS.Record.Reading ( + recvRecord, + recvRecord13, +) where import Control.Monad.Reader import qualified Data.ByteString as B @@ -31,7 +30,12 @@ exceeds ctx overhead actual = 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 @@ -40,12 +44,13 @@ getRecord ctx appDataOverhead header@(Header pt _ _) content = do 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 @@ -55,29 +60,35 @@ contentSizeExceeded = Error_Protocol "record content exceeding maximum size" Rec -- | 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 + :: 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 - | otherwise = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader) - - where recvLengthE = either (return . Left) recvLength + | 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) + 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 @@ -94,4 +105,10 @@ readExactBytes ctx sz = do 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/core/Network/TLS/Record/State.hs b/core/Network/TLS/Record/State.hs index e8bd8372b..3c235a279 100644 --- a/core/Network/TLS/Record/State.hs +++ b/core/Network/TLS/Record/State.hs @@ -1,106 +1,119 @@ {-# 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 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.Types +import Network.TLS.Util import qualified Data.ByteString as B 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 master secret (TLS < 1.3) + CryptMasterSecret + | -- | 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 (<*>) = ap instance Monad RecordM where - return a = RecordM $ \_ st -> Right (a, st) + 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 +122,56 @@ getRecordVersion :: RecordM Version 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 + :: 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 - - (macF, msg) - | ver < TLS10 = (macSSL hashA, B.concat [ encodedSeq, encodeHeaderNoVer hdr, content ]) - | otherwise = (hmac hashA, B.concat [ encodedSeq, encodeHeader hdr, content ]) + where + digest = macF (cstMacSecret cst) msg + cst = stCryptState tstate + cipher = fromJust "cipher" $ 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]) makeDigest :: Header -> ByteString -> RecordM ByteString makeDigest hdr content = do diff --git a/core/Network/TLS/Record/Types.hs b/core/Network/TLS/Record/Types.hs index cffe1a49a..3239492a9 100644 --- a/core/Network/TLS/Record/Types.hs +++ b/core/Network/TLS/Record/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE EmptyDataDecls #-} + -- | -- Module : Network.TLS.Record.Types -- License : BSD-style @@ -11,43 +12,47 @@ -- 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 +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 +67,40 @@ fragmentCompressed bytes = Fragment bytes 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/core/Network/TLS/Record/Writing.hs b/core/Network/TLS/Record/Writing.hs index 21b10bc8e..b83ff9ea2 100644 --- a/core/Network/TLS/Record/Writing.hs +++ b/core/Network/TLS/Record/Writing.hs @@ -6,12 +6,11 @@ -- Portability : unknown -- -- TLS record layer in Tx direction --- -module Network.TLS.Record.Writing - ( encodeRecord - , encodeRecord13 - , sendBytes - ) where +module Network.TLS.Record.Writing ( + encodeRecord, + encodeRecord13, + sendBytes, +) where import Network.TLS.Cap import Network.TLS.Cipher @@ -35,23 +34,28 @@ encodeRecord ctx = prepareRecord ctx . encodeRecordM -- 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) + ver <- + usingState_ + ctx + (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) txState <- readMVar $ ctxTxState 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 + 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) + then do + newIV <- getStateRNG ctx sz + runTxState ctx (modify (setRecordIV newIV) >> f) else runTxState 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] ---------------------------------------------------------------- diff --git a/core/Network/TLS/Sending.hs b/core/Network/TLS/Sending.hs index 25102a101..a5e070b31 100644 --- a/core/Network/TLS/Sending.hs +++ b/core/Network/TLS/Sending.hs @@ -7,13 +7,12 @@ -- -- the Sending module contains calls related to marshalling packets according -- to the TLS state --- module Network.TLS.Sending ( - encodePacket - , encodePacket13 - , updateHandshake - , updateHandshake13 - ) where + encodePacket, + encodePacket13, + updateHandshake, + updateHandshake13, +) where import Network.TLS.Cipher import Network.TLS.Context.Internal @@ -29,7 +28,7 @@ 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 @@ -39,8 +38,12 @@ 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 + :: Monoid bytes + => Context + -> RecordLayer bytes + -> Packet + -> IO (Either TLSError bytes) encodePacket ctx recordLayer pkt = do (ver, _) <- decideRecordVersion ctx let pt = packetType pkt @@ -55,39 +58,53 @@ encodePacket ctx recordLayer pkt = do -- 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) = +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] +packetToFragments _ _ (Alert a) = return [encodeAlerts a] +packetToFragments _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] +packetToFragments _ _ (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) + 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) -- 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 + && cc == 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 () + _ -> return () usingHState ctx $ do when (certVerifyHandshakeMaterial hs) $ addHandshakeMessage encoded - when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ updateHandshakeDigest encoded + when (finishHandshakeTypeMaterial $ typeOfHandshake 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) @@ -96,16 +113,16 @@ encodePacket13 ctx recordLayer pkt = do fmap mconcat <$> forEitherM records (recordEncode13 recordLayer) 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 +131,8 @@ updateHandshake13 ctx hs 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/core/Network/TLS/Session.hs b/core/Network/TLS/Session.hs index cf5b8bbe8..abc507bf2 100644 --- a/core/Network/TLS/Session.hs +++ b/core/Network/TLS/Session.hs @@ -4,31 +4,31 @@ -- 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. + { sessionResume :: SessionID -> IO (Maybe SessionData) + -- ^ used on server side to decide whether to resume a client session. , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData) - -- | used when a session is established. - , sessionEstablish :: SessionID -> SessionData -> IO () - -- | used when a session is invalidated. - , sessionInvalidate :: SessionID -> IO () + -- ^ 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. + , sessionEstablish :: SessionID -> SessionData -> IO () + -- ^ used when a session is established. + , sessionInvalidate :: SessionID -> IO () + -- ^ used when a session is invalidated. } -- | 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 () + , sessionInvalidate = \_ -> return () + } diff --git a/core/Network/TLS/State.hs b/core/Network/TLS/State.hs index 624006096..376fbe327 100644 --- a/core/Network/TLS/State.hs +++ b/core/Network/TLS/State.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} + -- | -- Module : Network.TLS.State -- License : BSD-style @@ -10,174 +11,175 @@ -- -- 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 +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, + -- * random - , genRandom - , withRNG - ) where + genRandom, + withRNG, +) where +import Control.Monad.State.Strict +import Crypto.Random +import qualified Data.ByteString as B +import Data.X509 (CertificateChain) +import Network.TLS.ErrT +import Network.TLS.Extension import Network.TLS.Imports +import Network.TLS.RNG import Network.TLS.Struct import Network.TLS.Struct13 -import Network.TLS.RNG -import Network.TLS.Types (Role(..), HostName) +import Network.TLS.Types (HostName, Role (..)) 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 Data.X509 (CertificateChain) 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 + , stSecureRenegotiation :: Bool -- RFC 5746 + , stClientVerifiedData :: ByteString -- RFC 5746 + , stServerVerifiedData :: ByteString -- RFC 5746 + , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) - , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol + , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString)) - , stClientALPNSuggest :: Maybe [B.ByteString] - , stClientGroupSuggest :: Maybe [Group] + , 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 + , 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) + , stClientSupportsPHA :: !Bool -- Post-Handshake Authentication (TLS 1.3) } -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 + , 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 + } 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 }) + then modify (\st -> st{stServerVerifiedData = bs}) + else modify (\st -> st{stClientVerifiedData = bs}) finishHandshakeTypeMaterial :: HandshakeType -> Bool -finishHandshakeTypeMaterial HandshakeType_ClientHello = True -finishHandshakeTypeMaterial HandshakeType_ServerHello = True -finishHandshakeTypeMaterial HandshakeType_Certificate = True -finishHandshakeTypeMaterial HandshakeType_HelloRequest = False +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 +finishHandshakeTypeMaterial HandshakeType_ClientKeyXchg = True +finishHandshakeTypeMaterial HandshakeType_ServerKeyXchg = True +finishHandshakeTypeMaterial HandshakeType_CertRequest = True +finishHandshakeTypeMaterial HandshakeType_CertVerify = True +finishHandshakeTypeMaterial HandshakeType_Finished = True finishHandshakeMaterial :: Handshake -> Bool finishHandshakeMaterial = finishHandshakeTypeMaterial . 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 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,64 +188,69 @@ isSessionResuming :: TLSSt Bool 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 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) +getVerifiedData client = + gets + (if client == ClientRole then stClientVerifiedData else stServerVerifiedData) isClientContext :: TLSSt Role isClientContext = gets stClientContext @@ -255,42 +262,42 @@ genRandom n = do 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 }) +setExporterMasterSecret key = modify (\st -> st{stExporterMasterSecret = Just key}) getExporterMasterSecret :: TLSSt (Maybe ByteString) getExporterMasterSecret = gets stExporterMasterSecret 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 diff --git a/core/Network/TLS/Struct.hs b/core/Network/TLS/Struct.hs index 0dd393d96..9ca12a607 100644 --- a/core/Network/TLS/Struct.hs +++ b/core/Network/TLS/Struct.hs @@ -1,5 +1,6 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK hide #-} + -- | -- Module : Network.TLS.Struct -- License : BSD-style @@ -8,73 +9,75 @@ -- 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) +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 Control.Exception (Exception (..)) import Data.Typeable -import Control.Exception (Exception(..)) -import Network.TLS.Types +import Data.X509 (CertificateChain, DistinguishedName) import Network.TLS.Crypto -import Network.TLS.Util.Serialization import Network.TLS.Imports +import Network.TLS.Types +import Network.TLS.Util.Serialization data ConnectionEnd = ConnectionServer | ConnectionClient data CipherType = CipherStream | CipherBlock | CipherAEAD data CipherData = CipherData { cipherDataContent :: ByteString - , cipherDataMAC :: Maybe ByteString + , cipherDataMAC :: Maybe ByteString , cipherDataPadding :: Maybe (ByteString, Int) - } deriving (Show,Eq) + } + 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 @@ -83,36 +86,38 @@ data CipherData = CipherData -- 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 +data CertificateType + = -- | TLS10 and up, RFC5246 + CertificateType_RSA_Sign + | -- | TLS10 and up, RFC5246 + CertificateType_DSS_Sign + | -- | TLS10 and up, RFC8422 + CertificateType_ECDSA_Sign + | -- | TLS13 and up, synthetic + CertificateType_Ed25519_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_Ed448_Sign + | 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_fortezza_dms -- Obsolete, unsupported + | CertificateType_RSA_Fixed_ECDH -- Obsolete, unsupported | CertificateType_ECDSA_Fixed_ECDH -- Obsolete, unsupported - | CertificateType_Unknown Word8 -- 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 +data HashAlgorithm + = HashNone | HashMD5 | HashSHA1 | HashSHA224 @@ -121,10 +126,10 @@ data HashAlgorithm = | HashSHA512 | HashIntrinsic | HashOther Word8 - deriving (Show,Eq) + deriving (Show, Eq) -data SignatureAlgorithm = - SignatureAnonymous +data SignatureAlgorithm + = SignatureAnonymous | SignatureRSA | SignatureDSS | SignatureECDSA @@ -137,7 +142,7 @@ data SignatureAlgorithm = | SignatureRSApsspssSHA384 | SignatureRSApsspssSHA512 | SignatureOther Word8 - deriving (Show,Eq) + deriving (Show, Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) @@ -146,10 +151,10 @@ type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) type Signature = ByteString data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature - deriving (Show,Eq) + deriving (Show, Eq) -data ProtocolType = - ProtocolType_ChangeCipherSpec +data ProtocolType + = ProtocolType_ChangeCipherSpec | ProtocolType_Alert | ProtocolType_Handshake | ProtocolType_AppData @@ -161,18 +166,20 @@ data ProtocolType = -- 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 +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_Warning String AlertDescription - -- ^ A non-fatal error condition was encountered at a low level at a low + 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 - | Error_HandshakePolicy String -- ^ handshake policy failed. + | -- | handshake policy failed. + Error_HandshakePolicy String | Error_EOF | Error_Packet String | Error_Packet_unexpected String String @@ -183,46 +190,48 @@ data TLSError = -- 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 = +data TLSException + = -- | Early termination exception with the reason and the error associated 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 + | -- | Handshake failed for the reason attached. + HandshakeFailed TLSError + | -- | Failure occurred while sending or receiving data after the -- TLS handshake succeeded. - | Uncontextualized TLSError - -- ^ Lifts a 'TLSError' into 'TLSException' without provided any context + PostHandshake 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 + 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. - | MissingHandshake - -- ^ Expected that a TLS handshake had already taken place, but no TLS + -- 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. - deriving (Show,Eq,Typeable) + -- Indicates that this library has been used incorrectly. + MissingHandshake + deriving (Show, Eq, Typeable) instance Exception TLSException -data Packet = - Handshake [Handshake] +data Packet + = Handshake [Handshake] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString - deriving (Show,Eq) + deriving (Show, Eq) -data Header = Header ProtocolType Version Word16 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 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 +type ExtensionID = Word16 -- | The raw content of a TLS extension. data ExtensionRaw = ExtensionRaw ExtensionID ByteString @@ -270,18 +279,19 @@ showEID 0x33 = "KeyShare" showEID 0x39 = "QuicTransportParameters" showEID 0xff01 = "SecureRenegotiation" showEID 0xffa5 = "QuicTransportParameters" -showEID x = show x +showEID x = show x -data AlertLevel = - AlertLevel_Warning +data AlertLevel + = AlertLevel_Warning | AlertLevel_Fatal - deriving (Show,Eq) + deriving (Show, Eq) -data AlertDescription = - CloseNotify +data AlertDescription + = CloseNotify | UnexpectedMessage | BadRecordMac - | DecryptionFailed -- ^ deprecated alert, should never be sent by compliant implementation + | -- | deprecated alert, should never be sent by compliant implementation + DecryptionFailed | RecordOverflow | DecompressionFailure | HandshakeFailure @@ -311,10 +321,10 @@ data AlertDescription = | UnknownPskIdentity | CertificateRequired | NoApplicationProtocol -- RFC7301 - deriving (Show,Eq) + deriving (Show, Eq) -data HandshakeType = - HandshakeType_HelloRequest +data HandshakeType + = HandshakeType_HelloRequest | HandshakeType_ClientHello | HandshakeType_ServerHello | HandshakeType_Certificate @@ -324,10 +334,10 @@ data HandshakeType = | HandshakeType_CertVerify | HandshakeType_ClientKeyXchg | HandshakeType_Finished - deriving (Show,Eq) + deriving (Show, Eq) newtype BigNum = BigNum ByteString - deriving (Show,Eq) + deriving (Show, Eq) bigNumToInteger :: BigNum -> Integer bigNumToInteger (BigNum b) = os2ip b @@ -339,33 +349,37 @@ data ServerDHParams = ServerDHParams { serverDHParams_p :: BigNum , serverDHParams_g :: BigNum , serverDHParams_y :: BigNum - } deriving (Show,Eq) + } + deriving (Show, Eq) serverDHParamsFrom :: DHParams -> DHPublic -> ServerDHParams serverDHParamsFrom params dhPub = - ServerDHParams (bigNumFromInteger $ dhParamsGetP params) - (bigNumFromInteger $ dhParamsGetG params) - (bigNumFromInteger $ dhUnwrapPublic 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) + 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) + deriving (Show, Eq) data ServerRSAParams = ServerRSAParams - { rsa_modulus :: Integer + { rsa_modulus :: Integer , rsa_exponent :: Integer - } deriving (Show,Eq) + } + deriving (Show, Eq) -data ServerKeyXchgAlgorithmData = - SKX_DH_Anon ServerDHParams +data ServerKeyXchgAlgorithmData + = SKX_DH_Anon ServerDHParams | SKX_DHE_DSS ServerDHParams DigitallySigned | SKX_DHE_RSA ServerDHParams DigitallySigned | SKX_ECDHE_RSA ServerECDHParams DigitallySigned @@ -375,50 +389,66 @@ data ServerKeyXchgAlgorithmData = | SKX_DH_RSA (Maybe ServerRSAParams) | SKX_Unparsed ByteString -- if we parse the server key xchg before knowing the actual cipher, we end up with this structure. | SKX_Unknown ByteString - deriving (Show,Eq) + deriving (Show, Eq) -data ClientKeyXchgAlgorithmData = - CKX_RSA ByteString +data ClientKeyXchgAlgorithmData + = CKX_RSA ByteString | CKX_DH DHPublic | CKX_ECDH ByteString - deriving (Show,Eq) + deriving (Show, Eq) type DeprecatedRecord = ByteString -data Handshake = - ClientHello !Version !ClientRandom !Session ![CipherID] ![CompressionID] [ExtensionRaw] (Maybe DeprecatedRecord) - | ServerHello !Version !ServerRandom !Session !CipherID !CompressionID [ExtensionRaw] +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] + | CertRequest + [CertificateType] + (Maybe [HashAndSignatureAlgorithm]) + [DistinguishedName] | CertVerify DigitallySigned | Finished FinishedData - deriving (Show,Eq) + deriving (Show, Eq) packetType :: Packet -> ProtocolType -packetType (Handshake _) = ProtocolType_Handshake -packetType (Alert _) = ProtocolType_Alert +packetType (Handshake _) = ProtocolType_Handshake +packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec -packetType (AppData _) = ProtocolType_AppData +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 +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 SSL2 = (2, 0) +numericalVer SSL3 = (3, 0) numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3) @@ -431,7 +461,7 @@ verOfNum (3, 1) = Just TLS10 verOfNum (3, 2) = Just TLS11 verOfNum (3, 3) = Just TLS12 verOfNum (3, 4) = Just TLS13 -verOfNum _ = Nothing +verOfNum _ = Nothing class TypeValuable a where valOfType :: a -> Word8 @@ -440,11 +470,11 @@ class TypeValuable a where -- a better name for TypeValuable class EnumSafe8 a where fromEnumSafe8 :: a -> Word8 - toEnumSafe8 :: Word8 -> Maybe a + toEnumSafe8 :: Word8 -> Maybe a class EnumSafe16 a where fromEnumSafe16 :: a -> Word16 - toEnumSafe16 :: Word16 -> Maybe a + toEnumSafe16 :: Word16 -> Maybe a instance TypeValuable ConnectionEnd where valOfType ConnectionServer = 0 @@ -456,8 +486,8 @@ instance TypeValuable ConnectionEnd where instance TypeValuable CipherType where valOfType CipherStream = 0 - valOfType CipherBlock = 1 - valOfType CipherAEAD = 2 + valOfType CipherBlock = 1 + valOfType CipherAEAD = 2 valToType 0 = Just CipherStream valToType 1 = Just CipherBlock @@ -465,33 +495,33 @@ instance TypeValuable CipherType where valToType _ = Nothing instance TypeValuable ProtocolType where - valOfType ProtocolType_ChangeCipherSpec = 20 - valOfType ProtocolType_Alert = 21 - valOfType ProtocolType_Handshake = 22 - valOfType ProtocolType_AppData = 23 + 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 + 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_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 + 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 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 @@ -499,74 +529,74 @@ instance TypeValuable HandshakeType where valToType 15 = Just HandshakeType_CertVerify valToType 16 = Just HandshakeType_ClientKeyXchg valToType 20 = Just HandshakeType_Finished - valToType _ = Nothing + valToType _ = Nothing instance TypeValuable AlertLevel where valOfType AlertLevel_Warning = 1 - valOfType AlertLevel_Fatal = 2 + 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 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 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 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 + 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 @@ -577,54 +607,55 @@ instance TypeValuable AlertDescription where valToType 115 = Just UnknownPskIdentity valToType 116 = Just CertificateRequired valToType 120 = Just NoApplicationProtocol - valToType _ = Nothing + 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_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_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 + 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 + 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 - -- @ + 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 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 @@ -639,54 +670,54 @@ instance TypeValuable HashAlgorithm where 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 + 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) + 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 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 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 + toEnumSafe16 _ = Nothing diff --git a/core/Network/TLS/Struct13.hs b/core/Network/TLS/Struct13.hs index dcd070be8..498f2f1fb 100644 --- a/core/Network/TLS/Struct13.hs +++ b/core/Network/TLS/Struct13.hs @@ -4,37 +4,37 @@ -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown --- -module Network.TLS.Struct13 - ( Packet13(..) - , Handshake13(..) - , HandshakeType13(..) - , typeOfHandshake13 - , contentType - , KeyUpdate(..) - ) where +module Network.TLS.Struct13 ( + Packet13 (..), + Handshake13 (..), + HandshakeType13 (..), + 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] +data Handshake13 + = ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw] | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw] | NewSessionTicket13 Second Word32 TicketNonce SessionID [ExtensionRaw] | EndOfEarlyData13 @@ -44,10 +44,10 @@ data Handshake13 = | CertVerify13 HashAndSignatureAlgorithm Signature | Finished13 FinishedData | KeyUpdate13 KeyUpdate - deriving (Show,Eq) + deriving (Show, Eq) -data HandshakeType13 = - HandshakeType_ClientHello13 +data HandshakeType13 + = HandshakeType_ClientHello13 | HandshakeType_ServerHello13 | HandshakeType_EndOfEarlyData13 | HandshakeType_NewSessionTicket13 @@ -57,46 +57,46 @@ data HandshakeType13 = | HandshakeType_CertVerify13 | HandshakeType_Finished13 | HandshakeType_KeyUpdate13 - deriving (Show,Eq) + deriving (Show, Eq) typeOfHandshake13 :: Handshake13 -> HandshakeType13 -typeOfHandshake13 ClientHello13{} = HandshakeType_ClientHello13 -typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello13 -typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13 -typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13 +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 +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 + 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 - 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 + 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 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 diff --git a/core/Network/TLS/Types.hs b/core/Network/TLS/Types.hs index cb3193460..d4459db23 100644 --- a/core/Network/TLS/Types.hs +++ b/core/Network/TLS/Types.hs @@ -1,83 +1,87 @@ {-# 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 +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 import Network.Socket (HostName) -import Network.TLS.Imports import Network.TLS.Crypto.Types (Group) +import Network.TLS.Imports -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) +data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13 + deriving (Show, Eq, Ord, Bounded) -- | A session ID type SessionID = ByteString -- | 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] + } + deriving (Show, Eq) -- | Some session flags data SessionFlag - = SessionEMS -- ^ Session created with Extended Master Secret - deriving (Show,Eq,Enum) + = -- | Session created with Extended Master Secret + SessionEMS + deriving (Show, Eq, Enum) -- | 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) -- | Cipher identification type CipherID = Word16 @@ -87,11 +91,11 @@ type CompressionID = Word8 -- | 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 @@ -108,25 +112,25 @@ data ApplicationSecret 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 } data SecretPair a = SecretPair - { pairBase :: BaseSecret a + { pairBase :: BaseSecret a , pairClient :: ClientTrafficSecret a } @@ -134,4 +138,4 @@ data SecretPair a = SecretPair type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) -- Master secret for TLS 1.2 or earlier. -newtype MasterSecret = MasterSecret ByteString deriving Show +newtype MasterSecret = MasterSecret ByteString deriving (Show) diff --git a/core/Network/TLS/Util.hs b/core/Network/TLS/Util.hs index 18664ee80..2a7c26b3f 100644 --- a/core/Network/TLS/Util.hs +++ b/core/Network/TLS/Util.hs @@ -1,69 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Network.TLS.Util - ( sub - , takelast - , partition3 - , partition6 - , fromJust - , (&&!) - , bytesEq - , fmapEither - , catchException - , forEitherM - , mapChunks_ - , getChunks - , Saved - , saveMVar - , restoreMVar - ) where + +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 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 + +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 fromJust :: String -> Maybe a -> a -fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck -fromJust _ (Just x) = x +fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck +fromJust _ (Just x) = x -- | 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. @@ -79,24 +86,29 @@ catchException :: IO a -> (SomeException -> IO a) -> IO a 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) - -mapChunks_ :: Monad m - => Maybe Int -> (B.ByteString -> m a) -> B.ByteString -> m () + doTail (Left e) = return (Left e) + +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/core/Network/TLS/Util/ASN1.hs b/core/Network/TLS/Util/ASN1.hs index eeb24f59c..601f587d9 100644 --- a/core/Network/TLS/Util/ASN1.hs +++ b/core/Network/TLS/Util/ASN1.hs @@ -6,32 +6,33 @@ -- Portability : unknown -- -- ASN1 utils for TLS --- -module Network.TLS.Util.ASN1 - ( decodeASN1Object - , encodeASN1Object - ) where +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/core/Network/TLS/Util/Serialization.hs b/core/Network/TLS/Util/Serialization.hs index aa70d2ec4..a5bccc005 100644 --- a/core/Network/TLS/Util/Serialization.hs +++ b/core/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/core/Network/TLS/Wire.hs b/core/Network/TLS/Wire.hs index 2fbba403c..53a692e02 100644 --- a/core/Network/TLS/Wire.hs +++ b/core/Network/TLS/Wire.hs @@ -7,81 +7,82 @@ -- -- 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 +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 +129,13 @@ getBigNum16 = BigNum <$> getOpaque16 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 +164,7 @@ putWord24 i = do 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/core/Network/TLS/X509.hs b/core/Network/TLS/X509.hs index 46dca0af6..f15fef9dd 100644 --- a/core/Network/TLS/X509.hs +++ b/core/Network/TLS/X509.hs @@ -6,61 +6,62 @@ -- 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 +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/core/Setup.hs b/core/Setup.hs index 9a994af67..e8ef27dbb 100644 --- a/core/Setup.hs +++ b/core/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/core/Tests/Certificate.hs b/core/Tests/Certificate.hs index 335116d44..c3328bedd 100644 --- a/core/Tests/Certificate.hs +++ b/core/Tests/Certificate.hs @@ -1,27 +1,28 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Certificate - ( arbitraryX509 - , arbitraryX509WithKey - , arbitraryX509WithKeyAndUsage - , arbitraryDN - , arbitraryKeyUsage - , simpleCertificate - , simpleX509 - , toPubKeyEC - , toPrivKeyEC - ) where + +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 Data.ASN1.OID import qualified Data.ByteString as B +import Data.Hourglass +import Data.X509 +import Test.Tasty.QuickCheck import PubKey @@ -31,7 +32,7 @@ arbitraryDN = return $ DistinguishedName [] instance Arbitrary Date where arbitrary = do y <- choose (1971, 2035) - m <- elements [ January .. December] + m <- elements [January .. December] d <- choose (1, 30) return $ normalizeDate $ Date y m d @@ -40,9 +41,9 @@ normalizeDate d = timeConvert (timeConvert d :: Elapsed) instance Arbitrary TimeOfDay where arbitrary = do - h <- choose (0, 23) - mi <- choose (0, 59) - se <- choose (0, 59) + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) nsec <- return 0 return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec @@ -54,23 +55,27 @@ maxSerial = 16777216 arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate arbitraryCertificate usageFlags pubKey = do - serial <- choose (0,maxSerial) + serial <- choose (0, maxSerial) subjectdn <- arbitraryDN - validity <- (,) <$> arbitrary <*> arbitrary + validity <- (,) <$> arbitrary <*> arbitrary let sigalg = getSignatureALG pubKey - return $ Certificate - { certVersion = 3 - , certSerial = serial + return $ + Certificate + { certVersion = 3 + , certSerial = serial , certSignatureAlg = sigalg - , certIssuerDN = issuerdn - , certSubjectDN = subjectdn - , certValidity = validity - , certPubKey = pubKey - , certExtensions = Extensions $ Just - [ extensionEncode True $ ExtKeyUsage usageFlags - ] + , certIssuerDN = issuerdn + , certSubjectDN = subjectdn + , certValidity = validity + , certPubKey = pubKey + , certExtensions = + Extensions $ + Just + [ extensionEncode True $ ExtKeyUsage usageFlags + ] } - where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] + where + issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] simpleCertificate :: PubKey -> Certificate simpleCertificate pubKey = @@ -78,35 +83,40 @@ simpleCertificate pubKey = { 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] - ] + , 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 [] + 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 + sig = replicate 40 1 sigalg = getSignatureALG pubKey - (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert + (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert in signedExact arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage -arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate +arbitraryX509WithKeyAndUsage + :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do cert <- arbitraryCertificate usageFlags pubKey - sig <- resize 40 $ listOf1 arbitrary + sig <- resize 40 $ listOf1 arbitrary let sigalg = getSignatureALG pubKey - let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert + let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig, sigalg, ())) cert return signedExact arbitraryX509 :: Gen SignedCertificate @@ -118,25 +128,27 @@ arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] arbitraryKeyUsage = sublistOf knownKeyUsage knownKeyUsage :: [ExtKeyUsageFlag] -knownKeyUsage = [ KeyUsage_digitalSignature - , KeyUsage_keyEncipherment - , KeyUsage_keyAgreement - ] +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 +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) + 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) diff --git a/core/Tests/Ciphers.hs b/core/Tests/Ciphers.hs index 0d630a4b4..520b609a0 100644 --- a/core/Tests/Ciphers.hs +++ b/core/Tests/Ciphers.hs @@ -1,8 +1,9 @@ -- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Ciphers - ( propertyBulkFunctional - ) where + +module Ciphers ( + propertyBulkFunctional, +) where import Control.Applicative ((<$>), (<*>)) @@ -22,29 +23,33 @@ 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) + 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 + 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 + (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 + 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/core/Tests/Connection.hs b/core/Tests/Connection.hs index ceed1f2e0..1afb76338 100644 --- a/core/Tests/Connection.hs +++ b/core/Tests/Connection.hs @@ -1,52 +1,53 @@ -- 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 +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 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 import Control.Concurrent.Async import Control.Concurrent.Chan -import Control.Concurrent import qualified Control.Exception as E import Control.Monad (unless, when) +import Data.Default.Class +import Data.IORef import Data.List (intersect, isInfixOf) +import Data.X509 +import Network.TLS as TLS +import Network.TLS.Extra +import PipeChan +import PubKey +import Test.Tasty.QuickCheck import qualified Data.ByteString as B @@ -56,55 +57,57 @@ 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 - ] + 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] +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) - ] +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 + 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 + 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 +knownECGroups = [P256, P384, X25519, X448] +knownFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096] +knownGroups = knownECGroups ++ knownFFGroups defaultECGroup :: Group -defaultECGroup = P256 -- same as defaultECCurve +defaultECGroup = P256 -- same as defaultECCurve otherKnownECGroups :: [Group] otherKnownECGroups = filter (/= defaultECGroup) knownECGroups @@ -114,7 +117,7 @@ arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True -isCredentialDSA _ = False +isCredentialDSA _ = False arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle @@ -127,15 +130,17 @@ arbitraryCredentialsOfEachType' = do (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) - ] + 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 @@ -143,44 +148,56 @@ 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 + 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 + 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 + | otherwise = Nothing isCustomDHParams :: DHParams -> Bool isCustomDHParams params = params == dhParams512 leafPublicKey :: CertificateChain -> Maybe PubKey -leafPublicKey (CertificateChain []) = Nothing -leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ getCertificate leaf) +leafPublicKey (CertificateChain []) = Nothing +leafPublicKey (CertificateChain (leaf : _)) = Just (certPubKey $ getCertificate leaf) isLeafRSA :: Maybe CertificateChain -> Bool isLeafRSA chain = case chain >>= leafPublicKey of - Just (PubKeyRSA _) -> True - _ -> False + 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]) + 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) @@ -191,14 +208,16 @@ arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt -- extension "Supported Elliptic Curves" / "Supported Groups". arbitraryGroupPair :: Gen ([Group], [Group]) arbitraryGroupPair = do - (serverECGroups, clientECGroups) <- arbitraryGroupPairWith defaultECGroup otherKnownECGroups + (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) + arbitraryGroupPairFrom list = + elements list >>= \e -> + arbitraryGroupPairWith e (filter (/= e) list) arbitraryGroupPairWith e es = do s <- sublistOf es c <- sublistOf es @@ -213,26 +232,32 @@ arbitraryPairParamsAt connectVersion = do -- 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 ]] + 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) + | 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) + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers, serverCiphers) where listWithOthers :: a -> Int -> [a] -> Gen [a] listWithOthers fixedElement maxOthers others | maxOthers < 1 = return [fixedElement] - | otherwise = sized $ \n -> do + | otherwise = sized $ \n -> do num <- choose (0, min n maxOthers) pos <- choose (0, num) prefix <- vectorOf pos $ elements others @@ -247,48 +272,59 @@ getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool isVersionEnabled ver (cparams, sparams) = - (ver `elem` supportedVersions (serverSupported sparams)) && - (ver `elem` supportedVersions (clientSupported cparams)) + (ver `elem` supportedVersions (serverSupported sparams)) + && (ver `elem` supportedVersions (clientSupported cparams)) -arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) +arbitraryHashSignaturePair + :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) arbitraryHashSignaturePair = do serverHashSignatures <- shuffle knownHashSignatures clientHashSignatures <- shuffle knownHashSignatures return (clientHashSignatures, serverHashSignatures) -arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) - -> ([Cipher], [Cipher]) - -> Gen (ClientParams, ServerParams) +arbitraryPairParamsWithVersionsAndCiphers + :: ([Version], [Version]) + -> ([Cipher], [Cipher]) + -> Gen (ClientParams, ServerParams) arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do - secNeg <- arbitrary - dhparams <- elements [dhParams512,ffdhe2048,ffdhe3072] + secNeg <- arbitrary + dhparams <- elements [dhParams512, ffdhe2048, ffdhe3072] - creds <- arbitraryCredentialsOfEachType + 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 - } + 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 @@ -300,9 +336,10 @@ 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 +arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements -arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) +arbitraryRSACredentialWithUsage + :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) arbitraryRSACredentialWithUsage usageFlags = do let (pubKey, privKey) = getGlobalRSAPair cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) @@ -310,17 +347,29 @@ arbitraryRSACredentialWithUsage usageFlags = do arbitraryEMSMode :: Gen (EMSMode, EMSMode) arbitraryEMSMode = (,) <$> gen <*> gen - where gen = elements [ NoEMS, AllowEMS, RequireEMS ] + where + gen = elements [NoEMS, AllowEMS, RequireEMS] -setEMSMode :: (EMSMode, EMSMode) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) +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 } - } + 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) @@ -331,32 +380,50 @@ 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 () - } +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 + :: (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 } +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 + :: (SessionID, SessionData) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) setPairParamsSessionResuming sessionStuff (clientState, serverState) = - ( clientState { clientWantSessionResume = Just sessionStuff } - , serverState) + ( clientState{clientWantSessionResume = Just sessionStuff} + , serverState + ) -newPairContext :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) +newPairContext + :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) newPairContext pipe (cParams, sParams) = do let noFlush = return () let noClose = return () @@ -371,40 +438,63 @@ newPairContext pipe (cParams, sParams) = do 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 + 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 + 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) - + 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) + 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 + pipe <- newPipe + _ <- runPipe pipe (cCtx, sCtx) <- newPairContext pipe params diff --git a/core/Tests/Marshalling.hs b/core/Tests/Marshalling.hs index 0b0897b6b..74a427611 100644 --- a/core/Tests/Marshalling.hs +++ b/core/Tests/Marshalling.hs @@ -1,34 +1,37 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Marshalling - ( someWords8 - , prop_header_marshalling_id - , prop_handshake_marshalling_id - , prop_handshake13_marshalling_id - ) where -import Control.Monad +module Marshalling ( + someWords8, + prop_header_marshalling_id, + prop_handshake_marshalling_id, + prop_handshake13_marshalling_id, +) where + import Control.Applicative -import Test.Tasty.QuickCheck -import Network.TLS.Internal +import Control.Monad import Network.TLS +import Network.TLS.Internal +import Test.Tasty.QuickCheck +import Certificate import qualified Data.ByteString as B import Data.Word -import Data.X509 (CertificateChain(..)) -import Certificate +import Data.X509 (CertificateChain (..)) genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i instance Arbitrary Version where - arbitrary = elements [ SSL2, SSL3, TLS10, TLS11, TLS12, TLS13 ] + arbitrary = elements [SSL2, SSL3, TLS10, TLS11, TLS12, TLS13] instance Arbitrary ProtocolType where - arbitrary = elements + arbitrary = + elements [ ProtocolType_ChangeCipherSpec , ProtocolType_Alert , ProtocolType_Handshake - , ProtocolType_AppData ] + , ProtocolType_AppData + ] instance Arbitrary Header where arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary @@ -41,108 +44,121 @@ instance Arbitrary ServerRandom where instance Arbitrary Session where arbitrary = do - i <- choose (1,2) :: Gen Int + 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 - ] + 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 - ] + 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 +arbitraryCiphersIDs = choose (0, 200) >>= vector arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0,200) >>= vector +arbitraryCompressionIDs = choose (0, 200) >>= vector someWords8 :: Int -> Gen [Word8] someWords8 = vector instance Arbitrary ExtensionRaw where arbitrary = - let arbitraryContent = choose (0,40) >>= genByteString + 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 + | 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 ] + 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 + 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) + , -- , 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 ] +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 + arbitrary = + oneof + [ arbitrary >>= \ver -> + ClientHello13 ver + <$> arbitrary + <*> arbitrary + <*> arbitraryCiphersIDs + <*> arbitraryHelloExtensions ver + , arbitrary >>= \ver -> + ServerHello13 + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver , NewSessionTicket13 <$> arbitrary <*> arbitrary @@ -154,13 +170,14 @@ instance Arbitrary Handshake13 where , CertRequest13 <$> arbitraryCertReqContext <*> arbitrary - , resize 2 (listOf arbitraryX509) >>= \certs -> Certificate13 - <$> arbitraryCertReqContext - <*> return (CertificateChain certs) - <*> replicateM (length certs) 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 ] + , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] {- quickcheck property -} @@ -170,17 +187,23 @@ 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 } + 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 + 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) + GotError e -> error ("got error: " ++ show e) GotSuccessRemaining _ _ -> error "got remaining byte left" GotSuccess (ty, content) -> fn ty content diff --git a/core/Tests/PipeChan.hs b/core/Tests/PipeChan.hs index 89c0098d3..e3f2df9fc 100644 --- a/core/Tests/PipeChan.hs +++ b/core/Tests/PipeChan.hs @@ -1,21 +1,21 @@ -- create a similar concept than a unix pipe. -module PipeChan - ( PipeChan(..) - , newPipe - , runPipe - , readPipeA - , readPipeB - , writePipeA - , writePipeB - ) where +module PipeChan ( + PipeChan (..), + newPipe, + runPipe, + readPipeA, + readPipeB, + writePipeA, + writePipeB, +) where import Control.Applicative -import Control.Concurrent.Chan import Control.Concurrent +import Control.Concurrent.Chan import Control.Monad (forever) import Data.ByteString (ByteString) -import Data.IORef 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 (Chan ByteString) (Chan ByteString) @@ -27,16 +27,22 @@ runUniPipe :: UniPipeChan -> IO ThreadId runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w getReadUniPipe :: UniPipeChan -> Chan ByteString -getReadUniPipe (UniPipeChan r _) = r +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 +data PipeChan + = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan newPipe :: IO PipeChan -newPipe = PipeChan <$> newIORef B.empty <*> newIORef B.empty <*> newUniPipeChan <*> newUniPipeChan +newPipe = + PipeChan + <$> newIORef B.empty + <*> newIORef B.empty + <*> newUniPipeChan + <*> newUniPipeChan runPipe :: PipeChan -> IO ThreadId runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC @@ -45,13 +51,13 @@ 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 +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 +writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s -- helper to read buffered data. readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString diff --git a/core/Tests/PubKey.hs b/core/Tests/PubKey.hs index e48cfad9b..2a4e7ec85 100644 --- a/core/Tests/PubKey.hs +++ b/core/Tests/PubKey.hs @@ -1,33 +1,33 @@ -module PubKey - ( arbitraryRSAPair - , arbitraryDSAPair - , arbitraryECDSAPair - , arbitraryEd25519Pair - , arbitraryEd448Pair - , globalRSAPair - , getGlobalRSAPair - , knownECCurves - , defaultECCurve - , dhParams512 - , dhParams768 - , dhParams1024 - , dsaParams - , rsaParams - ) where +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.DH as DH 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.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 Control.Concurrent.MVar import System.IO.Unsafe @@ -53,48 +53,67 @@ 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 + 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 - } +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 - } +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 - } +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 - } +dsaParams = + DSA.Params + { DSA.params_p = + 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb + , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b + , DSA.params_g = + 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff + } arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) arbitraryDSAPair = do @@ -104,9 +123,10 @@ arbitraryDSAPair = do -- for performance reason P521 is not tested knownECCurves :: [ECC.CurveName] -knownECCurves = [ ECC.SEC_p256r1 - , ECC.SEC_p384r1 - ] +knownECCurves = + [ ECC.SEC_p256r1 + , ECC.SEC_p384r1 + ] defaultECCurve :: ECC.CurveName defaultECCurve = ECC.SEC_p256r1 @@ -118,7 +138,7 @@ arbitraryECDSAPair curveName = do return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d) where curve = ECC.getCurveByName curveName - n = ECC.ecc_n . ECC.common_curve $ curve + n = ECC.ecc_n . ECC.common_curve $ curve arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) arbitraryEd25519Pair = do diff --git a/core/Tests/Tests.hs b/core/Tests/Tests.hs index 8c4281cd3..4d17e731f 100644 --- a/core/Tests/Tests.hs +++ b/core/Tests/Tests.hs @@ -1,33 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} +import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck -import Test.QuickCheck.Monadic -import PipeChan +import Ciphers import Connection import Marshalling -import Ciphers +import PipeChan import PubKey -import Data.Foldable (traverse_) -import Data.Maybe import Data.Default.Class +import Data.Foldable (traverse_) import Data.List (intersect) +import Data.Maybe +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad 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 Data.X509 (ExtKeyUsageFlag (..)) import System.Timeout @@ -53,10 +53,15 @@ prop_pipe_work = do 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 () + | 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 @@ -73,59 +78,71 @@ runTLSPipeN n params tlsServer tlsClient = do 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 + :: (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 + :: (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) + 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 + :: (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]) + 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 [] @@ -133,78 +150,85 @@ runTLSPipeCapture13 params = do 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 + 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 () + 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 + 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 + params <- pick arbitraryPairParams runTLSPipeSimple params prop_handshake13_initiate :: PropertyM IO () prop_handshake13_initiate = do - params <- pick arbitraryPairParams13 + params <- pick arbitraryPairParams13 let cgrps = supportedGroups $ clientSupported $ fst params sgrps = supportedGroups $ serverSupported $ snd params hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest @@ -217,13 +241,14 @@ prop_handshake_keyupdate = do prop_handshake13_downgrade :: PropertyM IO () prop_handshake13_downgrade = do - (cparam,sparam) <- pick arbitraryPairParams + (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) + 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 @@ -231,49 +256,58 @@ prop_handshake13_downgrade = do 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 } - ) + 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 } - ) + 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 } - ) + 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 @@ -292,19 +326,23 @@ prop_handshake13_psk = do 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 } - ) + 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 @@ -319,38 +357,47 @@ prop_handshake13_psk_fallback = do 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] - } + 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 } - ) + 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 @@ -363,8 +410,8 @@ prop_handshake13_rtt0 = do 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) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + params2 = (pc{clientEarlyData = Just earlyData}, ps) runTLSPipeSimple13 params2 RTT0 (Just earlyData) @@ -372,19 +419,24 @@ 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 } - ) + 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 @@ -398,17 +450,20 @@ prop_handshake13_rtt0_fallback = do 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 - } - ) + 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 @@ -417,18 +472,23 @@ 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 } - ) + 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 @@ -440,26 +500,29 @@ prop_handshake13_rtt0_length = do 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) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + params2 = (pc{clientEarlyData = Just earlyData}, ps) (mode, mEarlyData) | clientLen > serverMax = (PreSharedKey, Nothing) - | otherwise = (RTT0, Just earlyData) + | 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 } - ) + 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 + eeMessagesHaveExt = + [ any isNegotiatedGroups exts + | EncryptedExtensions13 exts <- serverMessages + ] + [True] `assertEq` eeMessagesHaveExt -- one EE message with extension prop_handshake_ciphersuites :: PropertyM IO () prop_handshake_ciphersuites = do @@ -467,48 +530,61 @@ prop_handshake_ciphersuites = do let version = if tls13 then TLS13 else TLS12 clientCiphers <- pick arbitraryCiphers serverCiphers <- pick arbitraryCiphers - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (clientCiphers, serverCiphers) + (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) + 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) + 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 } - } + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = clientHashSigs + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = serverHashSigs + } + } commonHashSigs = clientHashSigs `intersect` serverHashSigs shouldFail - | tls13 = all incompatibleWithDefaultCurve commonHashSigs + | tls13 = all incompatibleWithDefaultCurve commonHashSigs | otherwise = null commonHashSigs if shouldFail - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') where incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 - incompatibleWithDefaultCurve _ = False + 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 @@ -520,27 +596,37 @@ 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) ] + 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) + (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 @@ -558,32 +644,47 @@ 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) ] + 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') + (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 @@ -591,27 +692,43 @@ 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) + 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 } - } + 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 @@ -619,176 +736,228 @@ prop_handshake_groups = do 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 - + 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)] + 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) + 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] - } - } + let serverParam' = + serverParam + { serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials [cred] + } + } hasDS = KeyUsage_digitalSignature `elem` usageFlags - hasKE = KeyUsage_keyEncipherment `elem` usageFlags + hasKE = KeyUsage_keyEncipherment `elem` usageFlags shouldSucceed = hasDS || (hasKE && not tls13) if shouldSucceed - then runTLSPipeSimple (clientParam,serverParam') - else runTLSInitFailure (clientParam,serverParam') + 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] + 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) - ] + hashSignatures = + [ (HashSHA256, SignatureECDSA) + ] clientVersion <- pick $ elements versions - (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers - ([clientVersion], versions) - (ciphers, ciphers) - clientGroups <- pick $ sublistOf sigGroups + (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 } - } + 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) + ecdsaDenied = + (clientVersion < TLS13 && null clientGroups) + || (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs) if ecdsaDenied - then runTLSInitFailure (clientParam',serverParam') - else runTLSPipeSimple (clientParam',serverParam') + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do - (clientParam,serverParam) <- pick arbitraryPairParams + (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 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) + 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 + (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 } - } + 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" + 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 + (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 } - } + 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') + then runTLSPipeSimple (clientParam', serverParam') + else runTLSInitFailure (clientParam', serverParam') prop_handshake_ems :: PropertyM IO () prop_handshake_ems = do @@ -811,8 +980,9 @@ prop_handshake_session_resumption_ems = do plainParams <- pick arbitraryPairParams ems <- pick (arbitraryEMSMode `suchThat` compatible) - let params = setEMSMode ems $ - setPairParamsSessionManagers sessionManagers plainParams + let params = + setEMSMode ems $ + setPairParamsSessionManagers sessionManagers plainParams runTLSPipeSimple params @@ -820,10 +990,11 @@ prop_handshake_session_resumption_ems = do sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) ems2 <- pick (arbitraryEMSMode `suchThat` compatible) - let params2 = setEMSMode ems2 $ - setPairParamsSessionResuming (fromJust sessionParams) params + let params2 = + setEMSMode ems2 $ + setPairParamsSessionResuming (fromJust sessionParams) params - let version = getConnectVersion params2 + let version = getConnectVersion params2 emsVersion = version >= TLS10 && version <= TLS12 if emsVersion && use ems && not (use ems2) @@ -832,107 +1003,128 @@ prop_handshake_session_resumption_ems = do runTLSPipeSimple params2 sessionParams2 <- run $ readClientSessionRef sessionRefs let sameSession = sessionParams == sessionParams2 - sameUse = use ems == use ems2 + sameUse = use ems == use ems2 when emsVersion $ assert (sameSession == sameUse) where compatible (NoEMS, RequireEMS) = False compatible (RequireEMS, NoEMS) = False - compatible _ = True + compatible _ = True use (NoEMS, _) = False use (_, NoEMS) = False - use _ = True + 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') + (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" + 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') + (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" + 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 - } - } + 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 + 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 @@ -953,37 +1145,45 @@ prop_handshake_session_resumption = do prop_thread_safety :: PropertyM IO () prop_thread_safety = do - params <- pick arbitraryPairParams + 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 + 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) +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 (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")) +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 @@ -1000,23 +1200,33 @@ checkCtxFinished ctx = do 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" +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" + 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) @@ -1026,21 +1236,27 @@ main = defaultMain $ testGroup "tls" , 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 + "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 + "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 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) @@ -1049,6 +1265,7 @@ main = defaultMain $ testGroup "tls" , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) ] - -- test concurrent reads and writes - tests_thread_safety = localOption (QuickCheckTests 10) $ + -- test concurrent reads and writes + tests_thread_safety = + localOption (QuickCheckTests 10) $ testProperty "Thread safety" (monadicIO prop_thread_safety) From 315896455460a8e515499c2be00d87dbf72940dd Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 23 Oct 2023 18:04:37 +0900 Subject: [PATCH 03/10] removing deprecated --- core/Network/TLS.hs | 2 -- core/Network/TLS/Context.hs | 30 ------------------------------ core/Network/TLS/Imports.hs | 1 - core/Network/TLS/RNG.hs | 1 - 4 files changed, 34 deletions(-) diff --git a/core/Network/TLS.hs b/core/Network/TLS.hs index e66c0d0b9..b9aac499b 100644 --- a/core/Network/TLS.hs +++ b/core/Network/TLS.hs @@ -172,8 +172,6 @@ module Network.TLS ( -- * Deprecated recvData', - contextNewOnHandle, - contextNewOnSocket, Bytes, ValidationChecks (..), ValidationHooks (..), diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index b6e04e134..3d9806a8b 100644 --- a/core/Network/TLS/Context.hs +++ b/core/Network/TLS/Context.hs @@ -39,10 +39,6 @@ module Network.TLS.Context ( -- * New contexts contextNew, - -- * Deprecated new contexts methods - contextNewOnHandle, - contextNewOnSocket, - -- * Context hooks contextHookSetHandshakeRecv, contextHookSetHandshake13Recv, @@ -94,10 +90,6 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict import Data.IORef --- deprecated imports -import Network.Socket (Socket) -import System.IO (Handle) - class TLSParams a where getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role @@ -220,28 +212,6 @@ contextNew backend params = liftIO $ do 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" #-} - --- | 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" #-} - contextHookSetHandshakeRecv :: Context -> (Handshake -> IO Handshake) -> IO () contextHookSetHandshakeRecv context f = contextModifyHooks context (\hooks -> hooks{hookRecvHandshake = f}) diff --git a/core/Network/TLS/Imports.hs b/core/Network/TLS/Imports.hs index a5c9f1423..05accf4f4 100644 --- a/core/Network/TLS/Imports.hs +++ b/core/Network/TLS/Imports.hs @@ -12,7 +12,6 @@ module Network.TLS.Imports ( (<&>), module Control.Applicative, module Control.Monad, - MonadFail, module Data.Bits, module Data.List, module Data.Maybe, diff --git a/core/Network/TLS/RNG.hs b/core/Network/TLS/RNG.hs index e085a529b..901be61e5 100644 --- a/core/Network/TLS/RNG.hs +++ b/core/Network/TLS/RNG.hs @@ -13,7 +13,6 @@ module Network.TLS.RNG ( ) where import Crypto.Random -import Crypto.Random.Types newtype StateRNG = StateRNG ChaChaDRG deriving (DRG) From 3f2df7647fb8a46932bcc325ae18c21639800e79 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:08:31 +0900 Subject: [PATCH 04/10] cabal gen-bounds for tls --- core/tls.cabal | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/core/tls.cabal b/core/tls.cabal index a44429296..a234f83a2 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -106,22 +106,22 @@ library default-language: Haskell2010 ghc-options: -Wall build-depends: - asn1-encoding, - asn1-types >=0.2.0, - async >=2.0, base >=4.9 && <5, - bytestring, - cereal >=0.5.3, - crypton, - crypton-x509 >=1.7.5, - crypton-x509-store >=1.6, - crypton-x509-validation >=1.6.5, - data-default-class, - memory >=0.14.6, - mtl >=2.2.1, - network >=2.4.0.0, - transformers, - unix-time + asn1-encoding >= 0.9.6 && < 0.10, + asn1-types >= 0.3.4 && < 0.4, + bytestring >= 0.11.5 && < 0.12, + memory >= 0.18.0 && < 0.19, + async >= 2.2.4 && < 2.3, + mtl >= 2.3.1 && < 2.4, + transformers >= 0.6.1 && < 0.7, + cereal >= 0.5.8 && < 0.6, + crypton >= 0.34 && < 0.35, + crypton-x509 >= 1.7.6 && < 1.8, + crypton-x509-store >= 1.6.9 && < 1.7, + crypton-x509-validation >= 1.6.12 && < 1.7, + data-default-class >= 0.1.2 && < 0.2, + network >= 3.1.4 && < 3.2, + unix-time >= 0.4.11 && < 0.5 test-suite test-tls type: exitcode-stdio-1.0 From 3cefe7033efaf4230c182010c5b82becede0262b Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:11:35 +0900 Subject: [PATCH 05/10] formolue for session --- session/Network/TLS/Imports.hs | 16 +-- session/Network/TLS/SessionManager.hs | 190 ++++++++++++-------------- session/Setup.hs | 1 + 3 files changed, 93 insertions(+), 114 deletions(-) diff --git a/session/Network/TLS/Imports.hs b/session/Network/TLS/Imports.hs index c3c452e64..cd99b7768 100644 --- a/session/Network/TLS/Imports.hs +++ b/session/Network/TLS/Imports.hs @@ -1,12 +1,12 @@ module Network.TLS.Imports ( - module Control.Applicative - , module Control.Monad - , module Data.Int - , module Data.List - , module Data.Maybe - , module Data.Monoid - , module Data.Word - ) where + module Control.Applicative, + module Control.Monad, + module Data.Int, + module Data.List, + module Data.Maybe, + module Data.Monoid, + module Data.Word, +) where import Control.Applicative import Control.Monad diff --git a/session/Network/TLS/SessionManager.hs b/session/Network/TLS/SessionManager.hs index 38d999249..246e7ac9e 100644 --- a/session/Network/TLS/SessionManager.hs +++ b/session/Network/TLS/SessionManager.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -- | In-memory TLS session manager. -- @@ -7,25 +6,21 @@ -- * Automatic pruning: old session data over their lifetime are pruned automatically. -- * Energy saving: no dedicate pruning thread is running when the size of session data database is zero. -- * (Replay resistance: each session data is used at most once to prevent replay attacks against 0RTT early data of TLS 1.3.) - module Network.TLS.SessionManager ( - Config(..) - , defaultConfig - , newSessionManager - ) where + Config (..), + defaultConfig, + newSessionManager, +) where import Basement.Block (Block) -import Data.ByteArray (convert) import Control.Exception (assert) import Control.Reaper +import Data.ByteArray (convert) import Data.ByteString (ByteString) import Data.IORef import Data.OrdPSQ (OrdPSQ) import qualified Data.OrdPSQ as Q import Network.TLS -#if !MIN_VERSION_tls(1,5,0) -import Network.TLS.Compression -#endif import qualified System.Clock as C import Network.TLS.Imports @@ -33,22 +28,23 @@ import Network.TLS.Imports ---------------------------------------------------------------- -- | Configuration for session managers. -data Config = Config { - -- | Ticket lifetime in seconds. - ticketLifetime :: !Int - -- | Pruning delay in seconds. This is set to 'reaperDelay'. - , pruningDelay :: !Int - -- | The limit size of session data entries. - , dbMaxSize :: !Int +data Config = Config + { ticketLifetime :: !Int + -- ^ Ticket lifetime in seconds. + , pruningDelay :: !Int + -- ^ Pruning delay in seconds. This is set to 'reaperDelay'. + , dbMaxSize :: !Int + -- ^ The limit size of session data entries. } -- | Lifetime: 1 day , delay: 10 minutes, max size: 1000 entries. defaultConfig :: Config -defaultConfig = Config { - ticketLifetime = 86400 - , pruningDelay = 6000 - , dbMaxSize = 1000 - } +defaultConfig = + Config + { ticketLifetime = 86400 + , pruningDelay = 6000 + , dbMaxSize = 1000 + } ---------------------------------------------------------------- @@ -56,62 +52,35 @@ toKey :: ByteString -> Block Word8 toKey = convert toValue :: SessionData -> SessionDataCopy -#if MIN_VERSION_tls(1,5,0) -#if MIN_VERSION_tls(1,5,3) toValue (SessionData v cid comp msni sec mg mti malpn siz flg) = SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg -#else -toValue (SessionData v cid comp msni sec mg mti malpn siz) = - SessionDataCopy v cid comp msni sec' mg mti malpn' siz -#endif where !sec' = convert sec !malpn' = convert <$> malpn -#else -toValue (SessionData v cid comp msni sec) = - SessionDataCopy v cid comp msni sec' - where - !sec' = convert sec -#endif fromValue :: SessionDataCopy -> SessionData -#if MIN_VERSION_tls(1,5,0) -#if MIN_VERSION_tls(1,5,3) fromValue (SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg) = SessionData v cid comp msni sec mg mti malpn siz flg -#else -fromValue (SessionDataCopy v cid comp msni sec' mg mti malpn' siz) = - SessionData v cid comp msni sec mg mti malpn siz -#endif where !sec = convert sec' !malpn = convert <$> malpn' -#else -fromValue (SessionDataCopy v cid comp msni sec') = - SessionData v cid comp msni sec - where - !sec = convert sec' -#endif ---------------------------------------------------------------- type SessionIDCopy = Block Word8 -data SessionDataCopy = SessionDataCopy - {- ssVersion -} !Version - {- ssCipher -} !CipherID - {- ssCompression -} !CompressionID - {- ssClientSNI -} !(Maybe HostName) - {- ssSecret -} (Block Word8) -#if MIN_VERSION_tls(1,5,0) - {- ssGroup -} !(Maybe Group) - {- ssTicketInfo -} !(Maybe TLS13TicketInfo) - {- ssALPN -} !(Maybe (Block Word8)) - {- ssMaxEarlyDataSize -} Int -#endif -#if MIN_VERSION_tls(1,5,3) - {- ssFlags -} [SessionFlag] -#endif - deriving (Show,Eq) +data SessionDataCopy + = SessionDataCopy + {- ssVersion -} !Version + {- ssCipher -} !CipherID + {- ssCompression -} !CompressionID + {- ssClientSNI -} !(Maybe HostName) + {- ssSecret -} (Block Word8) + {- ssGroup -} !(Maybe Group) + {- ssTicketInfo -} !(Maybe TLS13TicketInfo) + {- ssALPN -} !(Maybe (Block Word8)) + {- ssMaxEarlyDataSize -} Int + {- ssFlags -} [SessionFlag] + deriving (Show, Eq) type Sec = Int64 type Value = (SessionDataCopy, IORef Availability) @@ -129,31 +98,31 @@ newSessionManager :: Config -> IO SessionManager newSessionManager conf = do let lifetime = fromIntegral $ ticketLifetime conf maxsiz = dbMaxSize conf - reaper <- mkReaper defaultReaperSettings { - reaperEmpty = Q.empty - , reaperCons = cons maxsiz - , reaperAction = clean - , reaperNull = Q.null - , reaperDelay = pruningDelay conf * 1000000 - } - return SessionManager { - sessionResume = resume reaper MultipleUse -#if MIN_VERSION_tls(1,5,0) - , sessionResumeOnlyOnce = resume reaper SingleUse -#endif - , sessionEstablish = establish reaper lifetime - , sessionInvalidate = invalidate reaper - - } + reaper <- + mkReaper + defaultReaperSettings + { reaperEmpty = Q.empty + , reaperCons = cons maxsiz + , reaperAction = clean + , reaperNull = Q.null + , reaperDelay = pruningDelay conf * 1000000 + } + return + SessionManager + { sessionResume = resume reaper MultipleUse + , sessionResumeOnlyOnce = resume reaper SingleUse + , sessionEstablish = establish reaper lifetime + , sessionInvalidate = invalidate reaper + } cons :: Int -> Item -> DB -> DB -cons lim (k,t,v,Add) db - | lim <= 0 = Q.empty - | Q.size db == lim = case Q.minView db of - Nothing -> assert False $ Q.insert k t v Q.empty - Just (_,_,_,db') -> Q.insert k t v db' - | otherwise = Q.insert k t v db -cons _ (k,_,_,Del) db = Q.delete k db +cons lim (k, t, v, Add) db + | lim <= 0 = Q.empty + | Q.size db == lim = case Q.minView db of + Nothing -> assert False $ Q.insert k t v Q.empty + Just (_, _, _, db') -> Q.insert k t v db' + | otherwise = Q.insert k t v db +cons _ (k, _, _, Del) db = Q.delete k db clean :: DB -> IO (DB -> DB) clean olddb = do @@ -161,7 +130,7 @@ clean olddb = do let !pruned = snd $ Q.atMostView currentTime olddb return $ merge pruned where - ins db (k,p,v) = Q.insert k p v db + ins db (k, p, v) = Q.insert k p v db -- There is not 'merge' API. -- We hope that newdb is smaller than pruned. merge pruned newdb = foldl' ins pruned entries @@ -170,41 +139,50 @@ clean olddb = do ---------------------------------------------------------------- -establish :: Reaper DB Item -> Sec - -> SessionID -> SessionData -> IO () +establish + :: Reaper DB Item + -> Sec + -> SessionID + -> SessionData + -> IO () establish reaper lifetime k sd = do ref <- newIORef Fresh !p <- (+ lifetime) . C.sec <$> C.getTime C.Monotonic - let !v = (sd',ref) - reaperAdd reaper (k',p,v,Add) + let !v = (sd', ref) + reaperAdd reaper (k', p, v, Add) where !k' = toKey k !sd' = toValue sd -resume :: Reaper DB Item -> Use - -> SessionID -> IO (Maybe SessionData) +resume + :: Reaper DB Item + -> Use + -> SessionID + -> IO (Maybe SessionData) resume reaper use k = do db <- reaperRead reaper case Q.lookup k' db of - Nothing -> return Nothing - Just (p,v@(sd,ref)) -> - case use of - SingleUse -> do - available <- atomicModifyIORef' ref check - reaperAdd reaper (k',p,v,Del) - return $ if available then Just (fromValue sd) else Nothing - MultipleUse -> return $ Just (fromValue sd) + Nothing -> return Nothing + Just (p, v@(sd, ref)) -> + case use of + SingleUse -> do + available <- atomicModifyIORef' ref check + reaperAdd reaper (k', p, v, Del) + return $ if available then Just (fromValue sd) else Nothing + MultipleUse -> return $ Just (fromValue sd) where - check Fresh = (Used,True) - check Used = (Used,False) + check Fresh = (Used, True) + check Used = (Used, False) !k' = toKey k -invalidate :: Reaper DB Item - -> SessionID -> IO () +invalidate + :: Reaper DB Item + -> SessionID + -> IO () invalidate reaper k = do db <- reaperRead reaper case Q.lookup k' db of - Nothing -> return () - Just (p,v) -> reaperAdd reaper (k',p,v,Del) + Nothing -> return () + Just (p, v) -> reaperAdd reaper (k', p, v, Del) where !k' = toKey k diff --git a/session/Setup.hs b/session/Setup.hs index 9a994af67..e8ef27dbb 100644 --- a/session/Setup.hs +++ b/session/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain From 9c08c0b896bee1036517c8187db916604d37f22f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:13:18 +0900 Subject: [PATCH 06/10] cabal gen-bounds for session --- session/tls-session-manager.cabal | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/session/tls-session-manager.cabal b/session/tls-session-manager.cabal index e410d7f54..d0f8d2a5a 100644 --- a/session/tls-session-manager.cabal +++ b/session/tls-session-manager.cabal @@ -20,13 +20,13 @@ library ghc-options: -Wall build-depends: base >=4.7 && <5, - auto-update, - basement, - bytestring, - clock, - memory, - psqueues >=0.2.3, - tls + auto-update >= 0.1.6 && < 0.2, + basement >= 0.0.16 && < 0.1, + bytestring >= 0.11.5 && < 0.12, + clock >= 0.8.4 && < 0.9, + memory >= 0.18.0 && < 0.19, + psqueues >= 0.2.8 && < 0.3, + tls >= 1.9.0 && < 1.10 if impl(ghc >=8) default-extensions: Strict StrictData From 4adaaed366226bbb9ea4a94375a5b5fb78a017c5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:16:38 +0900 Subject: [PATCH 07/10] removing BangPatterns --- session/Network/TLS/SessionManager.hs | 44 +++++++++++++-------------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/session/Network/TLS/SessionManager.hs b/session/Network/TLS/SessionManager.hs index 246e7ac9e..37ceb64f8 100644 --- a/session/Network/TLS/SessionManager.hs +++ b/session/Network/TLS/SessionManager.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns #-} - -- | In-memory TLS session manager. -- -- * Limitation: you can set the maximum size of the session data database. @@ -29,11 +27,11 @@ import Network.TLS.Imports -- | Configuration for session managers. data Config = Config - { ticketLifetime :: !Int + { ticketLifetime :: Int -- ^ Ticket lifetime in seconds. - , pruningDelay :: !Int + , pruningDelay :: Int -- ^ Pruning delay in seconds. This is set to 'reaperDelay'. - , dbMaxSize :: !Int + , dbMaxSize :: Int -- ^ The limit size of session data entries. } @@ -55,29 +53,29 @@ toValue :: SessionData -> SessionDataCopy toValue (SessionData v cid comp msni sec mg mti malpn siz flg) = SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg where - !sec' = convert sec - !malpn' = convert <$> malpn + sec' = convert sec + malpn' = convert <$> malpn fromValue :: SessionDataCopy -> SessionData fromValue (SessionDataCopy v cid comp msni sec' mg mti malpn' siz flg) = SessionData v cid comp msni sec mg mti malpn siz flg where - !sec = convert sec' - !malpn = convert <$> malpn' + sec = convert sec' + malpn = convert <$> malpn' ---------------------------------------------------------------- type SessionIDCopy = Block Word8 data SessionDataCopy = SessionDataCopy - {- ssVersion -} !Version - {- ssCipher -} !CipherID - {- ssCompression -} !CompressionID - {- ssClientSNI -} !(Maybe HostName) + {- ssVersion -} Version + {- ssCipher -} CipherID + {- ssCompression -} CompressionID + {- ssClientSNI -} (Maybe HostName) {- ssSecret -} (Block Word8) - {- ssGroup -} !(Maybe Group) - {- ssTicketInfo -} !(Maybe TLS13TicketInfo) - {- ssALPN -} !(Maybe (Block Word8)) + {- ssGroup -} (Maybe Group) + {- ssTicketInfo -} (Maybe TLS13TicketInfo) + {- ssALPN -} (Maybe (Block Word8)) {- ssMaxEarlyDataSize -} Int {- ssFlags -} [SessionFlag] deriving (Show, Eq) @@ -127,7 +125,7 @@ cons _ (k, _, _, Del) db = Q.delete k db clean :: DB -> IO (DB -> DB) clean olddb = do currentTime <- C.sec <$> C.getTime C.Monotonic - let !pruned = snd $ Q.atMostView currentTime olddb + let pruned = snd $ Q.atMostView currentTime olddb return $ merge pruned where ins db (k, p, v) = Q.insert k p v db @@ -147,12 +145,12 @@ establish -> IO () establish reaper lifetime k sd = do ref <- newIORef Fresh - !p <- (+ lifetime) . C.sec <$> C.getTime C.Monotonic - let !v = (sd', ref) + p <- (+ lifetime) . C.sec <$> C.getTime C.Monotonic + let v = (sd', ref) reaperAdd reaper (k', p, v, Add) where - !k' = toKey k - !sd' = toValue sd + k' = toKey k + sd' = toValue sd resume :: Reaper DB Item @@ -173,7 +171,7 @@ resume reaper use k = do where check Fresh = (Used, True) check Used = (Used, False) - !k' = toKey k + k' = toKey k invalidate :: Reaper DB Item @@ -185,4 +183,4 @@ invalidate reaper k = do Nothing -> return () Just (p, v) -> reaperAdd reaper (k', p, v, Del) where - !k' = toKey k + k' = toKey k From 4602248972f4fd0e52baf42bfda4e667f41a83be Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:20:10 +0900 Subject: [PATCH 08/10] fourmolu --- core/Network/TLS/Imports.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/core/Network/TLS/Imports.hs b/core/Network/TLS/Imports.hs index 05accf4f4..1f93f3bc1 100644 --- a/core/Network/TLS/Imports.hs +++ b/core/Network/TLS/Imports.hs @@ -24,6 +24,7 @@ module Network.TLS.Imports ( import Data.ByteString (ByteString) import Data.ByteString.Char8 () + -- instance import Data.Functor From 6f1d2d53e15b7061719810958725006d1515a4b9 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 09:21:43 +0900 Subject: [PATCH 09/10] fourmolu for debug --- debug/Setup.hs | 1 + debug/src/CheckCiphers.hs | 122 ++++--- debug/src/Common.hs | 79 ++-- debug/src/HexDump.hs | 140 +++---- debug/src/Imports.hs | 16 +- debug/src/RetrieveCertificate.hs | 217 ++++++----- debug/src/SimpleClient.hs | 590 ++++++++++++++++++------------ debug/src/SimpleServer.hs | 602 +++++++++++++++++++------------ debug/src/Stunnel.hs | 277 +++++++++----- 9 files changed, 1237 insertions(+), 807 deletions(-) diff --git a/debug/Setup.hs b/debug/Setup.hs index 9a994af67..e8ef27dbb 100644 --- a/debug/Setup.hs +++ b/debug/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/debug/src/CheckCiphers.hs b/debug/src/CheckCiphers.hs index eacc00ab8..7693dfb25 100644 --- a/debug/src/CheckCiphers.hs +++ b/debug/src/CheckCiphers.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} import Control.Concurrent -import Control.Exception (SomeException(..)) +import Control.Exception (SomeException (..)) import qualified Control.Exception as E import qualified Crypto.Random.AESCtr as RNG import qualified Data.ByteString as B @@ -57,80 +57,103 @@ tableCiphers = , (0x006D, "DH_anon_WITH_AES_256_CBC_SHA256") ] -fakeCipher cid = Cipher - { cipherID = cid - , cipherName = "cipher-" ++ show cid - , cipherBulk = Bulk - { bulkName = "fake" - , bulkKeySize = 0 - , bulkIVSize = 0 - , bulkBlockSize = 0 - , bulkF = undefined +fakeCipher cid = + Cipher + { cipherID = cid + , cipherName = "cipher-" ++ show cid + , cipherBulk = + Bulk + { bulkName = "fake" + , bulkKeySize = 0 + , bulkIVSize = 0 + , bulkBlockSize = 0 + , bulkF = undefined + } + , cipherKeyExchange = CipherKeyExchange_RSA + , cipherHash = + Hash + { hashName = "fake" + , hashSize = 0 + , hashF = undefined + } + , cipherMinVer = Nothing } - , cipherKeyExchange = CipherKeyExchange_RSA - , cipherHash = Hash - { hashName = "fake" - , hashSize = 0 - , hashF = undefined - } - , cipherMinVer = Nothing - } -clienthello ciphers = ClientHello TLS10 (ClientRandom $ B.pack [0..31]) (Session Nothing) ciphers [0] [] Nothing +clienthello ciphers = + ClientHello + TLS10 + (ClientRandom $ B.pack [0 .. 31]) + (Session Nothing) + ciphers + [0] + [] + Nothing openConnection :: String -> String -> [Word16] -> IO (Maybe Word16) openConnection s p ciphers = do - pn <- if and $ map isDigit $ p + pn <- + if and $ map isDigit $ p then return $ fromIntegral $ (read p :: Int) else do service <- getServiceByName p "tcp" return $ servicePort service - he <- getHostByName s - sock <- socket AF_INET Stream defaultProtocol + he <- getHostByName s + sock <- socket AF_INET Stream defaultProtocol connect sock (SockAddrInet pn (head $ hostAddresses he)) handle <- socketToHandle sock ReadWriteMode rng <- RNG.makeSystem - let params = defaultParamsClient { pCiphers = map fakeCipher ciphers } + let params = defaultParamsClient{pCiphers = map fakeCipher ciphers} ctx <- contextNewOnHandle handle params rng sendPacket ctx $ Handshake [clienthello ciphers] - E.catch (do - rpkt <- recvPacket ctx - ccid <- case rpkt of - Right (Handshake ((ServerHello _ _ _ i _ _):_)) -> return i - _ -> error ("expecting server hello, packet received: " ++ show rpkt) - bye ctx - hClose handle - return $ Just ccid - ) (\(SomeException _) -> return Nothing) + E.catch + ( do + rpkt <- recvPacket ctx + ccid <- case rpkt of + Right (Handshake ((ServerHello _ _ _ i _ _) : _)) -> return i + _ -> + error ("expecting server hello, packet received: " ++ show rpkt) + bye ctx + hClose handle + return $ Just ccid + ) + (\(SomeException _) -> return Nothing) connectRange :: String -> String -> Int -> [Word16] -> IO (Int, [Word16]) connectRange d p v r = do ccidopt <- openConnection d p r threadDelay v case ccidopt of - Nothing -> return (1, []) + Nothing -> return (1, []) Just ccid -> do {-divide and conquer TLS-} let newr = filter ((/=) ccid) r - let (lr, rr) = if length newr > 2 - then splitAt (length newr `div` 2) newr - else (newr, []) - (lc, ls) <- if length lr > 0 - then connectRange d p v lr - else return (0,[]) - (rc, rs) <- if length rr > 0 - then connectRange d p v rr - else return (0,[]) + let (lr, rr) = + if length newr > 2 + then splitAt (length newr `div` 2) newr + else (newr, []) + (lc, ls) <- + if length lr > 0 + then connectRange d p v lr + else return (0, []) + (rc, rs) <- + if length rr > 0 + then connectRange d p v rr + else return (0, []) return (1 + lc + rc, [ccid] ++ ls ++ rs) -connectBetween d p v chunkSize ep sp = concat <$> loop sp where - loop a = liftM2 (:) (snd <$> connectRange d p v range) - (if a + chunkSize > ep then return [] else loop (a+64)) - where - range = if a + chunkSize > ep - then [a..ep] - else [a..sp+chunkSize] +connectBetween d p v chunkSize ep sp = concat <$> loop sp + where + loop a = + liftM2 + (:) + (snd <$> connectRange d p v range) + (if a + chunkSize > ep then return [] else loop (a + 64)) + where + range = + if a + chunkSize > ep + then [a .. ep] + else [a .. sp + chunkSize] {- data PArgs = PArgs @@ -159,6 +182,7 @@ progArgs = PArgs main = do putStrLn "broken" + {- _ <- printf "connecting to %s on port %s ...\n" (destination a) (port a) supported <- connectBetween (destination a) (port a) (speed a) (fromIntegral $ nb a) (fromIntegral $ end a) (fromIntegral $ start a) diff --git a/debug/src/Common.hs b/debug/src/Common.hs index db71b27c0..0215f9827 100644 --- a/debug/src/Common.hs +++ b/debug/src/Common.hs @@ -1,23 +1,24 @@ +{-# LANGUAGE CPP #-} -- Disable this warning so we can still test deprecated functionality. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# LANGUAGE CPP #-} -module Common - ( printCiphers - , printDHParams - , printGroups - , readNumber - , readCiphers - , readDHParams - , readGroups - , printHandshakeInfo - , makeAddrInfo - , AddrInfo(..) - , getCertificateStore - ) where + +module Common ( + printCiphers, + printDHParams, + printGroups, + readNumber, + readCiphers, + readDHParams, + readGroups, + printHandshakeInfo, + makeAddrInfo, + AddrInfo (..), + getCertificateStore, +) where import Data.Char (isDigit) -import Numeric (showHex) import Network.Socket +import Numeric (showHex) import Crypto.System.CPU import Data.X509.CertificateStore @@ -40,9 +41,9 @@ namedDHParams = namedCiphersuites :: [(String, [CipherID])] namedCiphersuites = - [ ("all", map cipherID ciphersuite_all) - , ("default", map cipherID ciphersuite_default) - , ("strong", map cipherID ciphersuite_strong) + [ ("all", map cipherID ciphersuite_all) + , ("default", map cipherID ciphersuite_default) + , ("strong", map cipherID ciphersuite_strong) ] namedGroups :: [(String, Group)] @@ -62,13 +63,13 @@ namedGroups = readNumber :: (Num a, Read a) => String -> Maybe a readNumber s | all isDigit s = Just $ read s - | otherwise = Nothing + | otherwise = Nothing readCiphers :: String -> Maybe [CipherID] readCiphers s = case lookup s namedCiphersuites of - Nothing -> (:[]) `fmap` readNumber s - just -> just + Nothing -> (: []) `fmap` readNumber s + just -> just readDHParams :: String -> IO (Maybe DHParams) readDHParams s = @@ -84,17 +85,24 @@ 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 + ( 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) + putStrLn + ("Using crypton-" ++ VERSION_crypton ++ " with CPU support for: " ++ cpuSupport) where pad n s | length s < n = s ++ replicate (n - length s) ' ' - | otherwise = s + | otherwise = s cpuSupport | null processorOptions = "(nothing)" @@ -117,7 +125,7 @@ printHandshakeInfo ctx = do info <- contextGetInformation ctx case info of Nothing -> return () - Just i -> do + Just i -> do putStrLn ("version: " ++ show (infoVersion i)) putStrLn ("cipher: " ++ show (infoCipher i)) putStrLn ("compression: " ++ show (infoCompression i)) @@ -130,26 +138,27 @@ printHandshakeInfo ctx = do sni <- getClientSNI ctx case sni of Nothing -> return () - Just n -> putStrLn ("server name indication: " ++ n) + 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 - } + 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) +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 [] = getSystemCertificateStore getCertificateStore paths = foldM readPathAppend mempty paths where readPathAppend acc path = do diff --git a/debug/src/HexDump.hs b/debug/src/HexDump.hs index 7d5abd98e..37e10f660 100644 --- a/debug/src/HexDump.hs +++ b/debug/src/HexDump.hs @@ -1,82 +1,96 @@ -module HexDump - ( hexdump - ) where +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 +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) + { 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 - } +defaultConfig = + BytedumpConfig + { configRowSize = 16 + , configRowGroupSize = 8 + , configRowGroupSep = " : " + , configRowLeft = " | " + , configRowRight = " | " + , configCellSep = " " + , configPrintChar = True + } disptable :: BytedumpConfig -> [Word8] -> [String] -disptable _ [] = [] -disptable cfg x = +disptable _ [] = [] +disptable cfg x = let (pre, post) = splitAt (configRowSize cfg) x - in tableRow pre : disptable cfg post + 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 + 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 "") - printChar :: Word8 -> Char - printChar w - | w >= 0x20 && w < 0x7f = toEnum $ fromIntegral w - | otherwise = '.' + splitMultiple _ [] = [] + splitMultiple n l = let (pre, post) = splitAt n l in pre : splitMultiple n post - 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 _ = ' ' + printChar :: Word8 -> Char + printChar w + | w >= 0x20 && w < 0x7f = toEnum $ fromIntegral w + | otherwise = '.' - {-# INLINE hexBytes #-} - hexBytes :: Word8 -> (Char, Char) - hexBytes w = (hex h, hex l) where (h,l) = (fromIntegral w) `divMod` 16 + 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 _ = ' ' - -- | Dump one byte into a 2 hexadecimal characters. - hexString :: Word8 -> String - hexString i = [h,l] where (h,l) = hexBytes i + {-# 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/debug/src/Imports.hs b/debug/src/Imports.hs index 534ec18db..4de72ac57 100644 --- a/debug/src/Imports.hs +++ b/debug/src/Imports.hs @@ -1,12 +1,12 @@ module Imports ( - ByteString - , module Control.Applicative - , module Control.Monad - , module Data.List - , module Data.Maybe - , module Data.Monoid - , module Data.Word - ) where + 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 diff --git a/debug/src/RetrieveCertificate.hs b/debug/src/RetrieveCertificate.hs index 26e95e458..74601fae0 100644 --- a/debug/src/RetrieveCertificate.hs +++ b/debug/src/RetrieveCertificate.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} import Control.Exception @@ -22,69 +23,103 @@ import Imports openConnection s p = do ref <- newIORef Nothing - let params = (defaultParamsClient s (B.pack p)) - { clientSupported = def { supportedCiphers = ciphersuite_all } - , clientShared = def { sharedValidationCache = noValidate } - } - - --ctx <- connectionClient s p params rng - let hints = defaultHints { addrSocketType = Stream } - addr:_ <- getAddrInfo (Just hints) (Just s) (Just p) - - sock <- bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) close $ \sock -> do - connect sock $ addrAddress addr - return sock + let params = + (defaultParamsClient s (B.pack p)) + { clientSupported = def{supportedCiphers = ciphersuite_all} + , clientShared = def{sharedValidationCache = noValidate} + } + + -- ctx <- connectionClient s p params rng + let hints = defaultHints{addrSocketType = Stream} + addr : _ <- getAddrInfo (Just hints) (Just s) (Just p) + + sock <- bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + close $ \sock -> do + connect sock $ addrAddress addr + return sock ctx <- contextNew sock params contextHookSetCertificateRecv ctx $ \l -> writeIORef ref (Just l) - _ <- handshake ctx + _ <- handshake ctx bye ctx r <- readIORef ref case r of - Nothing -> error "cannot retrieve any certificate" + Nothing -> error "cannot retrieve any certificate" Just certs -> return certs - where noValidate = ValidationCache (\_ _ _ -> return ValidationCachePass) - (\_ _ _ -> return ()) - -data Flag = PrintChain - | Format String - | Verify - | GetFingerprint - | VerifyFQDN String - | Help - deriving (Show,Eq) + where + noValidate = + ValidationCache + (\_ _ _ -> return ValidationCachePass) + (\_ _ _ -> return ()) + +data Flag + = PrintChain + | Format String + | Verify + | GetFingerprint + | VerifyFQDN String + | Help + deriving (Show, Eq) options :: [OptDescr Flag] options = - [ Option [] ["chain"] (NoArg PrintChain) "output the chain of certificate used" - , Option [] ["format"] (ReqArg Format "format") "define the output format (full, pem, default: simple)" - , Option [] ["verify"] (NoArg Verify) "verify the chain received with the trusted system certificate" - , Option [] ["fingerprint"] (NoArg GetFingerprint) "show fingerprint (SHA1)" - , Option [] ["verify-domain-name"] (ReqArg VerifyFQDN "fqdn") "verify the chain against a specific FQDN" - , Option ['h'] ["help"] (NoArg Help) "request help" + [ Option + [] + ["chain"] + (NoArg PrintChain) + "output the chain of certificate used" + , Option + [] + ["format"] + (ReqArg Format "format") + "define the output format (full, pem, default: simple)" + , Option + [] + ["verify"] + (NoArg Verify) + "verify the chain received with the trusted system certificate" + , Option [] ["fingerprint"] (NoArg GetFingerprint) "show fingerprint (SHA1)" + , Option + [] + ["verify-domain-name"] + (ReqArg VerifyFQDN "fqdn") + "verify the chain against a specific FQDN" + , Option ['h'] ["help"] (NoArg Help) "request help" ] showCert "pem" cert = B.putStrLn $ pemWriteBS pem - where pem = PEM { pemName = "CERTIFICATE" - , pemHeader = [] - , pemContent = encodeSignedObject cert - } + where + pem = + PEM + { pemName = "CERTIFICATE" + , pemHeader = [] + , pemContent = encodeSignedObject cert + } showCert "full" cert = putStrLn $ show cert - -showCert _ (signedCert) = do +showCert _ (signedCert) = do putStrLn ("serial: " ++ (show $ certSerial cert)) putStrLn ("issuer: " ++ (show $ certIssuerDN cert)) putStrLn ("subject: " ++ (show $ certSubjectDN cert)) - putStrLn ("validity: " ++ (show $ fst $ certValidity cert) ++ " to " ++ (show $ snd $ certValidity cert)) - where cert = getCertificate signedCert + putStrLn + ( "validity: " + ++ (show $ fst $ certValidity cert) + ++ " to " + ++ (show $ snd $ certValidity cert) + ) + where + cert = getCertificate signedCert printUsage = - putStrLn $ usageInfo "usage: retrieve-certificate [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options + putStrLn $ + usageInfo + "usage: retrieve-certificate [opts] [port]\n\n\t(port default to: 443)\noptions:\n" + options main = do args <- getArgs - let (opts,other,errs) = getOpt Permute options args + let (opts, other, errs) = getOpt Permute options args when (not $ null errs) $ do putStrLn $ show errs exitFailure @@ -94,50 +129,56 @@ main = do exitSuccess case other of - [destination,port] -> doMain destination port opts - [destination] -> doMain destination "443" opts - _ -> printUsage >> exitFailure - - where outputFormat [] = "simple" - outputFormat (Format s:_ ) = s - outputFormat (_ :xs) = outputFormat xs - - getFQDN [] = Nothing - getFQDN (VerifyFQDN fqdn:_) = Just fqdn - getFQDN (_:xs) = getFQDN xs - - doMain destination port opts = do - _ <- printf "connecting to %s on port %s ...\n" destination port - - chain <- openConnection destination port - let (CertificateChain certs) = chain - format = outputFormat opts - fqdn = getFQDN opts - case PrintChain `elem` opts of - True -> - forM_ (zip [0..] certs) $ \(n, cert) -> do - putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######") - showCert format cert - False -> - showCert format $ head certs - - let fingerprints = foldl (doFingerprint (head certs)) [] opts - unless (null fingerprints) $ putStrLn ("Fingerprints:") - mapM_ (\(alg,fprint) -> putStrLn (" " ++ alg ++ " = " ++ show fprint)) $ concat fingerprints - - when (Verify `elem` opts) $ do - store <- getSystemCertificateStore - putStrLn "### certificate chain trust" - let checks = defaultChecks { checkExhaustive = True - , checkFQHN = maybe False (const True) fqdn } - servId = (maybe "" id fqdn, B.empty) - reasons <- validate X509.HashSHA256 def checks store def servId chain - when (not $ null reasons) $ do putStrLn "fail validation:" - putStrLn $ show reasons - - doFingerprint cert acc GetFingerprint = - [ ("SHA1", getFingerprint cert X509.HashSHA1) - , ("SHA256", getFingerprint cert X509.HashSHA256) - , ("SHA512", getFingerprint cert X509.HashSHA512) - ] : acc - doFingerprint _ acc _ = acc + [destination, port] -> doMain destination port opts + [destination] -> doMain destination "443" opts + _ -> printUsage >> exitFailure + where + outputFormat [] = "simple" + outputFormat (Format s : _) = s + outputFormat (_ : xs) = outputFormat xs + + getFQDN [] = Nothing + getFQDN (VerifyFQDN fqdn : _) = Just fqdn + getFQDN (_ : xs) = getFQDN xs + + doMain destination port opts = do + _ <- printf "connecting to %s on port %s ...\n" destination port + + chain <- openConnection destination port + let (CertificateChain certs) = chain + format = outputFormat opts + fqdn = getFQDN opts + case PrintChain `elem` opts of + True -> + forM_ (zip [0 ..] certs) $ \(n, cert) -> do + putStrLn ("###### Certificate " ++ show (n + 1 :: Int) ++ " ######") + showCert format cert + False -> + showCert format $ head certs + + let fingerprints = foldl (doFingerprint (head certs)) [] opts + unless (null fingerprints) $ putStrLn ("Fingerprints:") + mapM_ (\(alg, fprint) -> putStrLn (" " ++ alg ++ " = " ++ show fprint)) $ + concat fingerprints + + when (Verify `elem` opts) $ do + store <- getSystemCertificateStore + putStrLn "### certificate chain trust" + let checks = + defaultChecks + { checkExhaustive = True + , checkFQHN = maybe False (const True) fqdn + } + servId = (maybe "" id fqdn, B.empty) + reasons <- validate X509.HashSHA256 def checks store def servId chain + when (not $ null reasons) $ do + putStrLn "fail validation:" + putStrLn $ show reasons + + doFingerprint cert acc GetFingerprint = + [ ("SHA1", getFingerprint cert X509.HashSHA1) + , ("SHA256", getFingerprint cert X509.HashSHA256) + , ("SHA512", getFingerprint cert X509.HashSHA512) + ] + : acc + doFingerprint _ acc _ = acc diff --git a/debug/src/SimpleClient.hs b/debug/src/SimpleClient.hs index 9a2cae0ba..147f56298 100644 --- a/debug/src/SimpleClient.hs +++ b/debug/src/SimpleClient.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -import Control.Exception (SomeException(..)) +import Control.Exception (SomeException (..)) import qualified Control.Exception as E import Crypto.Random import qualified Data.ByteString as B @@ -9,7 +9,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as LC import Data.Default.Class import Data.IORef -import Network.Socket (socket, close, connect) +import Network.Socket (close, connect, socket) import System.Console.GetOpt import System.Environment import System.Exit @@ -26,177 +26,282 @@ import Imports defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000 -bogusCipher cid = cipher_AES128_SHA1 { cipherID = cid } +bogusCipher cid = cipher_AES128_SHA1{cipherID = cid} 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 + 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 ref = SessionManager - { sessionEstablish = \sid sdata -> writeIORef ref (sid,sdata) - , sessionResume = \sid -> readIORef ref >>= \(s,d) -> if s == sid then return (Just d) else return Nothing - , sessionResumeOnlyOnce = \_ -> fail "sessionResumeOnlyOnce not implemented for simple client" - , sessionInvalidate = \_ -> return () - } +sessionRef ref = + SessionManager + { sessionEstablish = \sid sdata -> writeIORef ref (sid, sdata) + , sessionResume = \sid -> + readIORef ref >>= \(s, d) -> if s == sid then return (Just d) else return Nothing + , sessionResumeOnlyOnce = \_ -> fail "sessionResumeOnlyOnce not implemented for simple client" + , sessionInvalidate = \_ -> return () + } getDefaultParams flags host store sStorage certCredsRequest session earlyData = (defaultParamsClient serverName BC.empty) - { clientSupported = def { supportedVersions = supportedVers - , supportedCiphers = myCiphers - , supportedGroups = getGroups flags - } + { 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 ()) - } + , 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 ()) + } , clientEarlyData = earlyData } - where - serverName = foldl f host flags - where f _ (SNI n) = n - f acc _ = acc + 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 + 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 + 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 + 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 + 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 = not (NoValidateCert `elem` flags) + 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 = not (NoValidateCert `elem` flags) getGroups flags = case getGroup >>= readGroups of - Nothing -> defaultGroups - Just [] -> defaultGroups + Nothing -> defaultGroups + Just [] -> defaultGroups Just groups -> groups where defaultGroups = supportedGroups def getGroup = foldl f Nothing flags - where f _ (Group g) = Just g - f acc _ = acc + where + f _ (Group 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 - | Group String - | Help - | UpdateKey - deriving (Show,Eq) +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 + | Group 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 Group "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" + [ 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 Group "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 = Nothing @@ -204,51 +309,74 @@ noSession = Nothing runOn (sStorage, certStore) flags port hostname | BenchSend `elem` flags = runBench True | BenchRecv `elem` flags = runBench False - | otherwise = do + | 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 + 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 + 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 + 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 + 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 " + 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") + ++ ( 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 + ++ "\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 @@ -268,66 +396,78 @@ runOn (sStorage, certStore) flags port hostname loopRecv out ctx bye ctx `E.catch` \(SomeException e) -> putStrLn $ "bye failed: " ++ show e return () - setup = maybe (return stdout) (flip openFile 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") >> return () - Just b | BC.null b -> return () - | otherwise -> BC.hPutStrLn out b >> loopRecv out ctx + setup = maybe (return stdout) (flip openFile 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") >> return () + 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'" + 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 + findURI [] = "/" + findURI (Uri u : _) = u + findURI (_ : xs) = findURI xs - userAgent = maybe "" (\s -> "\r\nUser-Agent: " ++ s) 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 + userAgent = maybe "" (\s -> "\r\nUser-Agent: " ++ s) 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 flags = getCertificateStore (foldr getPaths [] flags) - where getPaths (TrustAnchor path) acc = path : acc - getPaths _ acc = acc + where + getPaths (TrustAnchor path) acc = path : acc + getPaths _ acc = acc printUsage = - putStrLn $ usageInfo "usage: simpleclient [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options + putStrLn $ + usageInfo + "usage: simpleclient [opts] [port]\n\n\t(port default to: 443)\noptions:\n" + options main = do args <- getArgs - let (opts,other,errs) = getOpt Permute options args + let (opts, other, errs) = getOpt Permute options args when (not $ null errs) $ do putStrLn $ show errs exitFailure @@ -347,6 +487,6 @@ main = do 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 + [hostname] -> runOn (sStorage, certStore) opts 443 hostname + [hostname, port] -> runOn (sStorage, certStore) opts (fromInteger $ read port) hostname + _ -> printUsage >> exitFailure diff --git a/debug/src/SimpleServer.hs b/debug/src/SimpleServer.hs index ddc891042..9f29360d8 100644 --- a/debug/src/SimpleServer.hs +++ b/debug/src/SimpleServer.hs @@ -10,7 +10,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as LC import Data.Default.Class import Data.X509.CertificateStore -import Network.Socket (socket, close, bind, listen, accept) +import Network.Socket (accept, bind, close, listen, socket) import qualified Network.Socket as S import Network.TLS.SessionManager import System.Console.GetOpt @@ -29,178 +29,280 @@ import Imports defaultBenchAmount = 1024 * 1024 defaultTimeout = 2000 -bogusCipher cid = cipher_AES128_SHA1 { cipherID = cid } +bogusCipher cid = cipher_AES128_SHA1{cipherID = cid} 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 + 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 + 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 = not (NoValidateCert `elem` flags) - allowRenegotiation = AllowRenegotiation `elem` flags + 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 = not (NoValidateCert `elem` flags) + allowRenegotiation = AllowRenegotiation `elem` flags getGroups flags = case getGroup >>= readGroups of - Nothing -> defaultGroups - Just [] -> defaultGroups + Nothing -> defaultGroups + Just [] -> defaultGroups Just groups -> groups where defaultGroups = supportedGroups def getGroup = foldl f Nothing flags - where f _ (Group 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 - | Group String - | Help - deriving (Show,Eq) + where + f _ (Group 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 + | Group 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 Group "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)" + [ 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 Group "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 (Just key) (Just cert) = do res <- credentialLoadX509 cert key case res of Left err -> error ("cannot load certificate: " ++ err) - Right v -> return v + Right v -> return v loadCred Nothing _ = error "missing credential key" -loadCred _ Nothing = +loadCred _ Nothing = error "missing credential certificate" runOn (sStorage, certStore) flags port = do @@ -213,113 +315,133 @@ runOn (sStorage, certStore) flags port = do 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) (flip openFile 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 sStorage cred False - runTLS False False params cSock $ \ctx -> do + runOn' sock + | BenchSend `elem` flags = runBench True sock + | BenchRecv `elem` flags = runBench False sock + | otherwise = do + -- certCredRequest <- getCredRequest + E.bracket + (maybe (return stdout) (flip openFile 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 sStorage 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 sStorage cred rtt0accept - - void $ forkIO $ - runTLS (Debug `elem` flags) - (IODebug `elem` flags) - params cSock $ \ctx -> do + `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 sStorage 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 + -- 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") >> return () - 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 + `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") >> return () + 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 flags = getCertificateStore (foldr getPaths [] flags) - where getPaths (TrustAnchor path) acc = path : acc - getPaths _ acc = acc + where + getPaths (TrustAnchor path) acc = path : acc + getPaths _ acc = acc printUsage = - putStrLn $ usageInfo "usage: simpleserver [opts] [port]\n\n\t(port default to: 443)\noptions:\n" options + putStrLn $ + usageInfo + "usage: simpleserver [opts] [port]\n\n\t(port default to: 443)\noptions:\n" + options main = do args <- getArgs - let (opts,other,errs) = getOpt Permute options args + let (opts, other, errs) = getOpt Permute options args when (not $ null errs) $ do putStrLn $ show errs exitFailure @@ -341,8 +463,8 @@ main = do exitSuccess certStore <- getTrustAnchors opts - sStorage <- newSessionManager defaultConfig + sStorage <- newSessionManager defaultConfig case other of - [] -> runOn (sStorage, certStore) opts 443 + [] -> runOn (sStorage, certStore) opts 443 [port] -> runOn (sStorage, certStore) opts (fromInteger $ read port) - _ -> printUsage >> exitFailure + _ -> printUsage >> exitFailure diff --git a/debug/src/Stunnel.hs b/debug/src/Stunnel.hs index be354d471..12557bacc 100644 --- a/debug/src/Stunnel.hs +++ b/debug/src/Stunnel.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} import Control.Concurrent (forkIO) -import Control.Exception (finally, throw, SomeException(..)) +import Control.Exception (SomeException (..), finally, throw) import qualified Control.Exception as E import qualified Crypto.PubKey.DH as DH () import qualified Data.ByteString as B @@ -29,8 +29,8 @@ loopUntil f = f >>= \v -> if v then return () else loopUntil f readOne h = do r <- E.try $ hWaitForInput h (-1) case r of - Left err -> if isEOFError err then return B.empty else throw err - Right True -> B.hGetNonBlocking h 4096 + Left err -> if isEOFError err then return B.empty else throw err + Right True -> B.hGetNonBlocking h 4096 Right False -> return B.empty tlsclient :: Handle -> Context -> IO () @@ -68,66 +68,76 @@ tlsserver srchandle dsthandle = do putStrLn "end" clientProcess dhParamsFile creds handle dsthandle dbg sessionManager _ = do - let logging = if not dbg - then def - else def { loggingPacketSent = putStrLn . ("debug: send: " ++) - , loggingPacketRecv = putStrLn . ("debug: recv: " ++) - } + let logging = + if not dbg + then def + else + def + { loggingPacketSent = putStrLn . ("debug: send: " ++) + , loggingPacketRecv = putStrLn . ("debug: recv: " ++) + } dhParams <- case dhParamsFile of - Nothing -> return Nothing - Just name -> readDHParams name - - let serverstate = def - { serverSupported = def { supportedCiphers = ciphersuite_default } - , serverShared = def { sharedCredentials = creds - , sharedSessionManager = sessionManager - } - , serverDHEParams = dhParams - } + Nothing -> return Nothing + Just name -> readDHParams name + + let serverstate = + def + { serverSupported = def{supportedCiphers = ciphersuite_default} + , serverShared = + def + { sharedCredentials = creds + , sharedSessionManager = sessionManager + } + , serverDHEParams = dhParams + } ctx <- contextNew handle serverstate contextHookSetLogging ctx logging tlsserver ctx dsthandle -data StunnelAddr = - AddrSocket Family SockAddr +data StunnelAddr + = AddrSocket Family SockAddr | AddrFD Handle Handle -data StunnelHandle = - StunnelSocket Socket - | StunnelFd Handle Handle +data StunnelHandle + = StunnelSocket Socket + | StunnelFd Handle Handle getAddressDescription :: Address -> IO StunnelAddr getAddressDescription (Address "tcp" desc) = do let (s, p) = break ((==) ':') desc - when (p == "") (error $ "missing port: expecting [source]:port got " ++ show desc) - addr:_ <- getAddrInfo Nothing (Just s) (Just $ drop 1 p) + when + (p == "") + (error $ "missing port: expecting [source]:port got " ++ show desc) + addr : _ <- getAddrInfo Nothing (Just s) (Just $ drop 1 p) return $ AddrSocket (addrFamily addr) (addrAddress addr) - getAddressDescription (Address "unix" desc) = do return $ AddrSocket AF_UNIX (SockAddrUnix desc) - getAddressDescription (Address "fd" _) = return $ AddrFD stdin stdout - -getAddressDescription a = error ("unrecognized source type (expecting tcp/unix/fd, got " ++ show a ++ ")") +getAddressDescription a = + error ("unrecognized source type (expecting tcp/unix/fd, got " ++ show a ++ ")") connectAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol - E.catch (connect sock sockaddr) - (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) + E.catch + (connect sock sockaddr) + ( \(SomeException e) -> + close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e) + ) return $ StunnelSocket sock - connectAddressDescription (AddrFD h1 h2) = do return $ StunnelFd h1 h2 listenAddressDescription (AddrSocket family sockaddr) = do sock <- socket family Stream defaultProtocol - E.catch (bind sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1) - (\(SomeException e) -> close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e)) + E.catch + (bind sock sockaddr >> listen sock 10 >> setSocketOption sock ReuseAddr 1) + ( \(SomeException e) -> + close sock >> error ("cannot open socket " ++ show sockaddr ++ " " ++ show e) + ) return $ StunnelSocket sock - listenAddressDescription (AddrFD _ _) = do error "cannot listen on fd" @@ -139,36 +149,43 @@ doClient source destination@(Address a _) flags = do let logging = if not (Debug `elem` flags) then def - else def { loggingPacketSent = putStrLn . ("debug: send: " ++) - , loggingPacketRecv = putStrLn . ("debug: recv: " ++) - } + else + def + { loggingPacketSent = putStrLn . ("debug: send: " ++) + , loggingPacketRecv = putStrLn . ("debug: recv: " ++) + } store <- getTrustAnchors flags let validateCache - | NoCertValidation `elem` flags = - ValidationCache (\_ _ _ -> return ValidationCachePass) - (\_ _ _ -> return ()) - | otherwise = def - let clientstate = (defaultParamsClient a B.empty) - { clientSupported = def { supportedCiphers = ciphersuite_all } - , clientShared = def { sharedCAStore = store, sharedValidationCache = validateCache } - } + | NoCertValidation `elem` flags = + ValidationCache + (\_ _ _ -> return ValidationCachePass) + (\_ _ _ -> return ()) + | otherwise = def + let clientstate = + (defaultParamsClient a B.empty) + { clientSupported = def{supportedCiphers = ciphersuite_all} + , clientShared = + def{sharedCAStore = store, sharedValidationCache = validateCache} + } case srcaddr of AddrSocket _ _ -> do (StunnelSocket srcsocket) <- listenAddressDescription srcaddr forever $ do (s, _) <- accept srcsocket - srch <- socketToHandle s ReadWriteMode + srch <- socketToHandle s ReadWriteMode - (StunnelSocket dst) <- connectAddressDescription dstaddr + (StunnelSocket dst) <- connectAddressDescription dstaddr dsth <- socketToHandle dst ReadWriteMode dstctx <- contextNew dsth clientstate contextHookSetLogging dstctx logging - _ <- forkIO $ finally - (tlsclient srch dstctx) - (hClose srch >> hClose dsth) + _ <- + forkIO $ + finally + (tlsclient srch dstctx) + (hClose srch >> hClose dsth) return () AddrFD _ _ -> error "bad error fd. not implemented" @@ -176,14 +193,15 @@ loadCred (cert, priv) = do putStrLn ("loading credential " ++ show cert ++ " : key=" ++ show priv) res <- credentialLoadX509 cert priv case res of - Left _ -> putStrLn "ERR" + Left _ -> putStrLn "ERR" Right _ -> putStrLn "OK" return res - doServer :: Address -> Address -> [Flag] -> IO () doServer source destination flags = do - creds <- (either (error . show) Credentials . sequence) `fmap` mapM loadCred (zip (getCertificate flags) (getKey flags)) + creds <- + (either (error . show) Credentials . sequence) + `fmap` mapM loadCred (zip (getCertificate flags) (getKey flags)) srcaddr <- getAddressDescription source dstaddr <- getAddressDescription destination let dhParamsFile = getDHParams flags @@ -201,20 +219,34 @@ doServer source destination flags = do srch <- socketToHandle s ReadWriteMode r <- connectAddressDescription dstaddr dsth <- case r of - StunnelFd _ _ -> return stdout + StunnelFd _ _ -> return stdout StunnelSocket dst -> socketToHandle dst ReadWriteMode - _ <- forkIO $ finally - (clientProcess dhParamsFile creds srch dsth (Debug `elem` flags) sessionManager addr >> return ()) - (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) + _ <- + forkIO $ + finally + ( clientProcess + dhParamsFile + creds + srch + dsth + (Debug `elem` flags) + sessionManager + addr + >> return () + ) + (hClose srch >> (when (dsth /= stdout) $ hClose dsth)) return () AddrFD _ _ -> error "bad error fd. not implemented" printUsage = - putStrLn $ usageInfo "usage: tls-stunnel [opts]\n\n\tmode:\n\tclient\n\tserver\n\nclient options:\n" options + putStrLn $ + usageInfo + "usage: tls-stunnel [opts]\n\n\tmode:\n\tclient\n\tserver\n\nclient options:\n" + options -data Flag = - Source String +data Flag + = Source String | Destination String | SourceType String | DestinationType String @@ -227,65 +259,112 @@ data Flag = | NoSession | NoCertValidation | TrustAnchor String - deriving (Show,Eq) + deriving (Show, Eq) options :: [OptDescr Flag] options = - [ Option ['s'] ["source"] (ReqArg Source "source") "source address influenced by source type" - , Option ['d'] ["destination"] (ReqArg Destination "destination") "destination address influenced by destination type" - , Option [] ["source-type"] (ReqArg SourceType "source-type") "type of source (tcp, unix, fd)" - , Option [] ["destination-type"] (ReqArg DestinationType "source-type") "type of source (tcp, unix, fd)" - , Option [] ["debug"] (NoArg Debug) "debug the TLS protocol printing debugging to stdout" - , Option ['h'] ["help"] (NoArg Help) "request help" - , Option [] ["list-dhparams"] (NoArg ListDHParams) "list all DH parameters supported and exit" - , Option [] ["certificate"] (ReqArg Certificate "certificate") "certificate file" - , Option [] ["key"] (ReqArg Key "key") "certificate file" - , Option [] ["dhparams"] (ReqArg DHParams "dhparams") "DH parameters (name or file)" - , Option [] ["no-session"] (NoArg NoSession) "disable support for session" - , Option [] ["no-cert-validation"] (NoArg NoCertValidation) "disable certificate validation" - , Option [] ["trust-anchor"] (ReqArg TrustAnchor "pem-or-dir") "use provided CAs instead of system certificate store" + [ Option + ['s'] + ["source"] + (ReqArg Source "source") + "source address influenced by source type" + , Option + ['d'] + ["destination"] + (ReqArg Destination "destination") + "destination address influenced by destination type" + , Option + [] + ["source-type"] + (ReqArg SourceType "source-type") + "type of source (tcp, unix, fd)" + , Option + [] + ["destination-type"] + (ReqArg DestinationType "source-type") + "type of source (tcp, unix, fd)" + , Option + [] + ["debug"] + (NoArg Debug) + "debug the TLS protocol printing debugging to stdout" + , Option ['h'] ["help"] (NoArg Help) "request help" + , Option + [] + ["list-dhparams"] + (NoArg ListDHParams) + "list all DH parameters supported and exit" + , Option + [] + ["certificate"] + (ReqArg Certificate "certificate") + "certificate file" + , Option [] ["key"] (ReqArg Key "key") "certificate file" + , Option + [] + ["dhparams"] + (ReqArg DHParams "dhparams") + "DH parameters (name or file)" + , Option [] ["no-session"] (NoArg NoSession) "disable support for session" + , Option + [] + ["no-cert-validation"] + (NoArg NoCertValidation) + "disable certificate validation" + , Option + [] + ["trust-anchor"] + (ReqArg TrustAnchor "pem-or-dir") + "use provided CAs instead of system certificate store" ] data Address = Address String String - deriving (Show,Eq) + deriving (Show, Eq) -defaultSource = Address "tcp" "localhost:6060" +defaultSource = Address "tcp" "localhost:6060" defaultDestination = Address "tcp" "localhost:6061" getSource opts = foldl accf defaultSource opts - where accf (Address t _) (Source s) = Address t s - accf (Address _ s) (SourceType t) = Address t s - accf acc _ = acc + where + accf (Address t _) (Source s) = Address t s + accf (Address _ s) (SourceType t) = Address t s + accf acc _ = acc getDestination opts = foldl accf defaultDestination opts - where accf (Address t _) (Destination s) = Address t s - accf (Address _ s) (DestinationType t) = Address t s - accf acc _ = acc + where + accf (Address t _) (Destination s) = Address t s + accf (Address _ s) (DestinationType t) = Address t s + accf acc _ = acc -onNull defVal l | null l = defVal - | otherwise = l +onNull defVal l + | null l = defVal + | otherwise = l getCertificate :: [Flag] -> [String] getCertificate opts = reverse $ onNull ["certificate.pem"] $ foldl accf [] opts - where accf acc (Certificate cert) = cert:acc - accf acc _ = acc + where + accf acc (Certificate cert) = cert : acc + accf acc _ = acc getKey opts = reverse $ onNull ["certificate.key"] $ foldl accf [] opts - where accf acc (Key key) = key : acc - accf acc _ = acc + where + accf acc (Key key) = key : acc + accf acc _ = acc getTrustAnchors flags = getCertificateStore (foldr getPaths [] flags) - where getPaths (TrustAnchor path) acc = path : acc - getPaths _ acc = acc + where + getPaths (TrustAnchor path) acc = path : acc + getPaths _ acc = acc getDHParams opts = foldl accf Nothing opts - where accf _ (DHParams file) = Just file - accf acc _ = acc + where + accf _ (DHParams file) = Just file + accf acc _ = acc main :: IO () main = do args <- getArgs - let (opts,other,errs) = getOpt Permute options args + let (opts, other, errs) = getOpt Permute options args when (not $ null errs) $ do putStrLn $ show errs exitFailure @@ -298,11 +377,11 @@ main = do printDHParams exitSuccess - let source = getSource opts + let source = getSource opts destination = getDestination opts case other of - [] -> printUsage - "client":_ -> doClient source destination opts - "server":_ -> doServer source destination opts - mode:_ -> error ("unknown mode " ++ show mode) + [] -> printUsage + "client" : _ -> doClient source destination opts + "server" : _ -> doServer source destination opts + mode : _ -> error ("unknown mode " ++ show mode) From b2782a825a7ca3d011181ba37f28075337196f87 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 20 Nov 2023 10:13:49 +0900 Subject: [PATCH 10/10] adding fourmolu.yaml --- fourmolu.yaml | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100644 fourmolu.yaml diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 000000000..13564e825 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,48 @@ +# Number of spaces per indentation step +indentation: 4 + +# Max line length for automatic line breaking +column-limit: 80 + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: leading + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: diff-friendly + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: false + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: single-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: inline + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: never + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] +