tls 1.4.1 → 1.5.0
raw patch · 54 files changed
+5815/−1040 lines, 54 filesdep +gaugedep −criteriondep ~basedep ~cerealdep ~cryptonite
Dependencies added: gauge
Dependencies removed: criterion
Dependency ranges changed: base, cereal, cryptonite, mtl, x509
Files
- Benchmarks/Benchmarks.hs +70/−25
- CHANGELOG.md +41/−1
- Network/TLS.hs +88/−83
- Network/TLS/Backend.hs +1/−1
- Network/TLS/Cipher.hs +3/−15
- Network/TLS/Context.hs +7/−2
- Network/TLS/Context/Internal.hs +52/−12
- Network/TLS/Core.hs +217/−43
- Network/TLS/Credentials.hs +17/−14
- Network/TLS/Crypto.hs +45/−45
- Network/TLS/Crypto/DH.hs +4/−0
- Network/TLS/Crypto/Types.hs +7/−6
- Network/TLS/Extension.hs +419/−51
- Network/TLS/Extra/Cipher.hs +434/−27
- Network/TLS/Handshake.hs +14/−6
- Network/TLS/Handshake/Certificate.hs +18/−0
- Network/TLS/Handshake/Client.hs +725/−146
- Network/TLS/Handshake/Common.hs +65/−8
- Network/TLS/Handshake/Common13.hs +340/−0
- Network/TLS/Handshake/Key.hs +57/−7
- Network/TLS/Handshake/Process.hs +25/−8
- Network/TLS/Handshake/Random.hs +77/−0
- Network/TLS/Handshake/Server.hs +586/−138
- Network/TLS/Handshake/Signature.hs +110/−20
- Network/TLS/Handshake/State.hs +219/−46
- Network/TLS/Handshake/State13.hs +138/−0
- Network/TLS/IO.hs +108/−18
- Network/TLS/Imports.hs +6/−0
- Network/TLS/KeySchedule.hs +62/−0
- Network/TLS/MAC.hs +3/−2
- Network/TLS/Packet.hs +67/−38
- Network/TLS/Packet13.hs +161/−0
- Network/TLS/Parameters.hs +158/−36
- Network/TLS/Receiving13.hs +49/−0
- Network/TLS/Record/Disengage.hs +18/−8
- Network/TLS/Record/Disengage13.hs +77/−0
- Network/TLS/Record/Engage.hs +13/−6
- Network/TLS/Record/Engage13.hs +69/−0
- Network/TLS/Record/State.hs +2/−0
- Network/TLS/Record/Types13.hs +24/−0
- Network/TLS/Sending13.hs +67/−0
- Network/TLS/Session.hs +9/−6
- Network/TLS/State.hs +55/−4
- Network/TLS/Struct.hs +99/−44
- Network/TLS/Struct13.hs +132/−0
- Network/TLS/Types.hs +20/−2
- Network/TLS/Util.hs +11/−8
- Network/TLS/Wire.hs +8/−0
- Tests/Certificate.hs +32/−10
- Tests/Connection.hs +155/−60
- Tests/Marshalling.hs +11/−12
- Tests/PubKey.hs +39/−3
- Tests/Tests.hs +556/−69
- tls.cabal +25/−10
Benchmarks/Benchmarks.hs view
@@ -4,9 +4,10 @@ import Connection import Certificate import PubKey-import Criterion.Main+import Gauge.Main import Control.Concurrent.Chan import Network.TLS+import Network.TLS.Extra.Cipher import Data.X509 import Data.X509.Validation import Data.Default.Class@@ -26,7 +27,7 @@ , bulkExplicitIV= 0 , bulkAuthTagLen= 0 , bulkBlockSize = 16- , bulkF = BulkBlockF $ \_ _ _ -> (\m -> (m, B.empty))+ , bulkF = BulkBlockF $ \ _ _ _ m -> (m, B.empty) } , cipherHash = MD5 , cipherPRFHash = Nothing@@ -34,9 +35,6 @@ , cipherMinVer = Nothing } -recvDataNonNull :: Context -> IO B.ByteString-recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l- getParams :: Version -> Cipher -> (ClientParams, ServerParams) getParams connectVer cipher = (cParams, sParams) where sParams = def { serverSupported = supported@@ -54,6 +52,7 @@ } supported = def { supportedCiphers = [cipher] , supportedVersions = [connectVer]+ , supportedGroups = [X25519, FFDHE2048] } (pubKey, privKey) = getGlobalRSAPair @@ -63,23 +62,22 @@ -> a -> IO b runTLSPipe params tlsServer tlsClient d = do- (startQueue, resultQueue) <- establishDataPipe params tlsServer tlsClient- writeChan startQueue d- readChan resultQueue+ (writeStart, readResult) <- establishDataPipe params tlsServer tlsClient+ writeStart d+ readResult runTLSPipeSimple :: (ClientParams, ServerParams) -> B.ByteString -> IO B.ByteString-runTLSPipeSimple params bs = runTLSPipe params tlsServer tlsClient bs+runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx- d <- recvDataNonNull ctx+ d <- recvData ctx writeChan queue d- return ()+ bye ctx tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d])- bye ctx- return ()+ byeBye ctx benchConnection :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark benchConnection params !d name = bench name . nfIO $ runTLSPipeSimple params d@@ -88,12 +86,12 @@ benchResumption params !d name = env initializeSession runResumption where initializeSession = do- sessionRef <- newIORef Nothing- let sessionManager = oneSessionManager sessionRef- params1 = setPairParamsSessionManager sessionManager params+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ params1 = setPairParamsSessionManagers sessionManagers params _ <- runTLSPipeSimple params1 d - Just sessionParams <- readIORef sessionRef+ Just sessionParams <- readClientSessionRef sessionRefs let params2 = setPairParamsSessionResuming sessionParams params1 newIORef params2 @@ -101,19 +99,66 @@ params2 <- readIORef paramsRef runTLSPipeSimple params2 d +benchResumption13 :: (ClientParams, ServerParams) -> B.ByteString -> String -> Benchmark+benchResumption13 params !d name = env initializeSession runResumption+ where+ initializeSession = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ params1 = setPairParamsSessionManagers sessionManagers params+ _ <- runTLSPipeSimple params1 d+ newIORef (params1, sessionRefs)++ -- with TLS13 the sessionId is constantly changing so we must update+ -- our parameters at each iteration unfortunately+ runResumption paramsRef = bench name . nfIO $ do+ (params1, sessionRefs) <- readIORef paramsRef+ Just sessionParams <- readClientSessionRef sessionRefs+ let params2 = setPairParamsSessionResuming sessionParams params1+ runTLSPipeSimple params2 d++benchCiphers :: String -> Version -> B.ByteString -> [Cipher] -> Benchmark+benchCiphers name connectVer d = bgroup name . map doBench+ where+ doBench cipher =+ benchResumption13 (getParams connectVer cipher) d (cipherName cipher)+ main :: IO () main = defaultMain [ bgroup "connection" -- not sure the number actually make sense for anything. improve ..- [ benchConnection (getParams SSL3 blockCipher) (B.replicate 256 0) "SSL3-256 bytes"- , benchConnection (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes"- , benchConnection (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes"- , benchConnection (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes"+ [ 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) (B.replicate 256 0) "SSL3-256 bytes"- , benchResumption (getParams TLS10 blockCipher) (B.replicate 256 0) "TLS10-256 bytes"- , benchResumption (getParams TLS11 blockCipher) (B.replicate 256 0) "TLS11-256 bytes"- , benchResumption (getParams TLS12 blockCipher) (B.replicate 256 0) "TLS12-256 bytes"+ [ 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
CHANGELOG.md view
@@ -1,7 +1,47 @@+## Version 1.5.0++- Add and enable AES CCM ciphers [#271](https://github.com/vincenthz/hs-tls/pull/271) [#287](https://github.com/vincenthz/hs-tls/pull/287)+- Verify certificate key usage [#274](https://github.com/vincenthz/hs-tls/pull/274) [#301](https://github.com/vincenthz/hs-tls/pull/301)+- TLS 1.3 support [#278](https://github.com/vincenthz/hs-tls/pull/278) [#279](https://github.com/vincenthz/hs-tls/pull/279) [#280](https://github.com/vincenthz/hs-tls/pull/280) [#283](https://github.com/vincenthz/hs-tls/pull/283) [#298](https://github.com/vincenthz/hs-tls/pull/298) [#331](https://github.com/vincenthz/hs-tls/pull/331) [#290](https://github.com/vincenthz/hs-tls/pull/290) [#314](https://github.com/vincenthz/hs-tls/pull/314)+- Enable RSASSA-PSS [#280](https://github.com/vincenthz/hs-tls/pull/280) [#353](https://github.com/vincenthz/hs-tls/pull/353)+- Add and enable ChaCha20-Poly1305 ciphers [#287](https://github.com/vincenthz/hs-tls/pull/287) [#340](https://github.com/vincenthz/hs-tls/pull/340)+- Certificate selection with extension "signature_algorithms_cert" [#302](https://github.com/vincenthz/hs-tls/pull/302)+- Preventing Logjam attack [#300](https://github.com/vincenthz/hs-tls/pull/300)+- Downgrade protection [#308](https://github.com/vincenthz/hs-tls/pull/308)+- Support for EdDSA certificates [#328](https://github.com/vincenthz/hs-tls/pull/328) [#353](https://github.com/vincenthz/hs-tls/pull/353)+- Key logging [#317](https://github.com/vincenthz/hs-tls/pull/317)+- Thread safety for writes [#329](https://github.com/vincenthz/hs-tls/pull/329)+- Verify signature schemes and (EC)DHE groups received [#337](https://github.com/vincenthz/hs-tls/pull/337) [#338](https://github.com/vincenthz/hs-tls/pull/338)+- Throw BadRecordMac when the decrypted record has invalid format [#347](https://github.com/vincenthz/hs-tls/pull/347)+- Improve documentation format [#341](https://github.com/vincenthz/hs-tls/pull/341) [#343](https://github.com/vincenthz/hs-tls/pull/343)+- Fix recvClientData with single Handshake packet [#352](https://github.com/vincenthz/hs-tls/pull/352)+- Decrease memory footprint of SessionData values [#354](https://github.com/vincenthz/hs-tls/pull/354)++FEATURES:++- TLS version 1.3 is available with most features but is not enabled by default.+ One notable omission is post-handshake authentication. Scenarios where+ servers previously used renegotiation to conditionally request a certificate+ are not possible yet when `TLS13` is negotiated. Users may enable the version+ in `supportedVersions` only when sure post-handshake authentication is not+ required.++API CHANGES:++- `SessionManager` implementations need to provide a `sessionResumeOnlyOnce`+ function to accomodate resumption scenarios with 0-RTT data. The function is+ called only on the server side.+- Data type `SessionData` is extended with four new fields for TLS version 1.3.+ `SessionManager` implementations that serializes/deserializes `SessionData`+ values must deal with the new fields.+- New configuration parameters and constructors are added for TLS version 1.3+ but the API change should be backward compatible for most use-cases.+- Function `cipherExchangeNeedMoreData` has been removed.+ ## Version 1.4.1 - Enable X25519 in default parameters [#265](https://github.com/vincenthz/hs-tls/pull/265)-- Checking EOF in bye [#262] (https://github.com/vincenthz/hs-tls/pull/262)+- Checking EOF in bye [#262](https://github.com/vincenthz/hs-tls/pull/262) - Improving validation in DH key exchange [#256](https://github.com/vincenthz/hs-tls/pull/256) - Handle TCP reset during handshake [#251](https://github.com/vincenthz/hs-tls/pull/251) - Accepting hlint suggestions.
Network/TLS.hs view
@@ -8,128 +8,132 @@ -- module Network.TLS (+ -- * Basic APIs+ Context+ , contextNew+ , handshake+ , sendData+ , recvData+ , bye++ -- * Backend abstraction+ , HasBackend(..)+ , Backend(..)+ -- * Context configuration- ClientParams(..)- , HostName- , Bytes+ -- ** Parameters+ -- intentionally hide the internal methods even haddock warns.+ , TLSParams+ , ClientParams(..)+ , defaultParamsClient , ServerParams(..)+ -- ** Supported+ , Supported(..)+ -- ** Shared+ , Shared(..)+ -- ** Debug parameters , DebugParams(..)- , DHParams- , DHPublic+ -- ** Client Server Hooks , ClientHooks(..)+ , OnCertificateRequest+ , OnServerCertificate , ServerHooks(..)- , Supported(..)- , Shared(..)+ -- ** Credentials+ , Credentials(..)+ , Credential+ , credentialLoadX509+ , credentialLoadX509FromMemory+ , credentialLoadX509Chain+ , credentialLoadX509ChainFromMemory+ -- ** Session+ , SessionID+ , SessionData(..)+ , SessionManager(..)+ , noSessionManager+ , TLS13TicketInfo+ -- ** Hooks , Hooks(..) , Handshake , Logging(..)+ , contextHookSetHandshakeRecv+ , contextHookSetCertificateRecv+ , contextHookSetLogging+ , contextModifyHooks+ -- ** Misc+ , HostName+ , DHParams+ , DHPublic , Measurement(..) , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..)- , defaultParamsClient , MaxFragmentEnum(..) , HashAndSignatureAlgorithm , HashAlgorithm(..) , SignatureAlgorithm(..) , CertificateType(..) - -- * raw types- , ProtocolType(..)- , Header(..)-- -- * Session- , SessionID- , SessionData(..)- , SessionManager(..)- , noSessionManager+ -- * X509+ -- ** X509 Validation+ , ValidationChecks(..)+ , ValidationHooks(..) - -- * Backend abstraction- , Backend(..)+ -- ** X509 Validation Cache+ , ValidationCache(..)+ , ValidationCacheResult(..)+ , exceptionValidationCache - -- * Context object- , Context+ -- * APIs+ -- ** Backend , ctxConnection- , TLSParams- , HasBackend(..)-- -- * Creating a context- , contextNew- , contextNewOnHandle-#ifdef INCLUDE_NETWORK- , contextNewOnSocket-#endif , contextFlush , contextClose- , contextHookSetHandshakeRecv- , contextHookSetCertificateRecv- , contextHookSetLogging- , contextModifyHooks-- -- * Information gathering+ -- ** Information gathering , Information(..)+ , contextGetInformation , ClientRandom , ServerRandom- , unClientRandom , unServerRandom- , contextGetInformation-- -- * Credentials- , Credentials(..)- , Credential- , credentialLoadX509- , credentialLoadX509FromMemory- , credentialLoadX509Chain- , credentialLoadX509ChainFromMemory-- -- * Initialisation and Termination of context- , bye- , handshake-- -- * Application Layer Protocol Negotiation+ -- ** Negotiated , getNegotiatedProtocol-- -- * Server Name Indication , getClientSNI-- -- * High level API- , sendData- , recvData- , recvData'-- -- * Crypto Key- , PubKey(..)- , PrivKey(..)+ -- ** Updating keys+ , updateKey+ , KeyUpdateRequest(..) - -- * Compressions & Predefined compressions+ -- * Raw types+ , ProtocolType(..)+ , Header(..)+ , Version(..)+ -- ** Compressions & Predefined compressions , module Network.TLS.Compression-- -- * Ciphers & Predefined ciphers+ , CompressionID+ -- ** Ciphers & Predefined ciphers , module Network.TLS.Cipher-- -- * Versions- , Version(..)+ -- ** Crypto Key+ , PubKey(..)+ , PrivKey(..)+ -- ** TLS 1.3+ , Group(..)+ , HandshakeMode13(..) - -- * Errors+ -- * Errors and exceptions+ -- ** Errors , TLSError(..) , KxError(..) , AlertDescription(..) - -- * Exceptions+ -- ** Exceptions , TLSException(..) - -- * X509 Validation- , ValidationChecks(..)- , ValidationHooks(..)-- -- * X509 Validation Cache- , ValidationCache(..)- , ValidationCacheResult(..)- , exceptionValidationCache-- -- * Key exchange group- , Group(..)+ -- * Deprecated+ , recvData'+ , contextNewOnHandle+#ifdef INCLUDE_NETWORK+ , contextNewOnSocket+#endif+ , Bytes ) where import Network.TLS.Backend (Backend(..), HasBackend(..))@@ -151,8 +155,9 @@ import Network.TLS.Session import Network.TLS.X509 import Network.TLS.Types+import Network.TLS.Handshake.State (HandshakeMode13(..)) import Data.X509 (PubKey(..), PrivKey(..))-import Data.X509.Validation+import Data.X509.Validation hiding (HostName) import Data.ByteString as B {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-}
Network/TLS/Backend.hs view
@@ -78,7 +78,7 @@ r <- safeRecv sock left if B.null r then return []- else liftM (r:) (loop (left - B.length r))+ else (r:) <$> loop (left - B.length r) #endif #ifdef INCLUDE_HANS
Network/TLS/Cipher.hs view
@@ -26,7 +26,6 @@ , BulkNonce , BulkAdditionalData , cipherAllowedForVersion- , cipherExchangeNeedMoreData , hasMAC , hasRecordIV ) where@@ -95,6 +94,7 @@ | CipherKeyExchange_ECDH_ECDSA | CipherKeyExchange_ECDH_RSA | CipherKeyExchange_ECDHE_ECDSA+ | CipherKeyExchange_TLS13 -- not expressed in cipher suite deriving (Show,Eq) data Bulk = Bulk@@ -136,23 +136,11 @@ cipherAllowedForVersion :: Version -> Cipher -> Bool cipherAllowedForVersion ver cipher = case cipherMinVer cipher of- Nothing -> True- Just cVer -> cVer <= ver+ Nothing -> ver < TLS13+ Just cVer -> cVer <= ver && (ver < TLS13 || cVer >= TLS13) instance Show Cipher where show c = cipherName c instance Eq Cipher where (==) c1 c2 = cipherID c1 == cipherID c2--cipherExchangeNeedMoreData :: CipherKeyExchangeType -> Bool-cipherExchangeNeedMoreData CipherKeyExchange_RSA = False-cipherExchangeNeedMoreData CipherKeyExchange_DH_Anon = True-cipherExchangeNeedMoreData CipherKeyExchange_DHE_RSA = True-cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_RSA = True-cipherExchangeNeedMoreData CipherKeyExchange_DHE_DSS = True-cipherExchangeNeedMoreData CipherKeyExchange_DH_DSS = False-cipherExchangeNeedMoreData CipherKeyExchange_DH_RSA = False-cipherExchangeNeedMoreData CipherKeyExchange_ECDH_ECDSA = True-cipherExchangeNeedMoreData CipherKeyExchange_ECDH_RSA = True-cipherExchangeNeedMoreData CipherKeyExchange_ECDHE_ECDSA = True
Network/TLS/Context.hs view
@@ -14,6 +14,7 @@ -- * Context object and accessor , Context(..) , Hooks(..)+ , Established(..) , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello@@ -60,6 +61,7 @@ , usingHState , getHState , getStateRNG+ , tls13orLater ) where import Network.TLS.Backend@@ -131,7 +133,7 @@ stvar <- newMVar st eof <- newIORef False- established <- newIORef False+ established <- newIORef NotEstablished stats <- newIORef newMeasurement -- we enable the reception of SSLv2 ClientHello message only in the -- server context, where we might be dealing with an old/compat client.@@ -141,6 +143,7 @@ tx <- newMVar newRecordState rx <- newMVar newRecordState hs <- newMVar Nothing+ as <- newIORef [] lockWrite <- newMVar () lockRead <- newMVar () lockState <- newMVar ()@@ -164,6 +167,8 @@ , ctxLockWrite = lockWrite , ctxLockRead = lockRead , ctxLockState = lockState+ , ctxPendingActions = as+ , ctxKeyLogger = debugKeyLogger debug } -- | create a new context on an handle.@@ -171,7 +176,7 @@ => Handle -- ^ Handle of the connection. -> params -- ^ Parameters of the context. -> m Context-contextNewOnHandle handle params = contextNew handle params+contextNewOnHandle = contextNew {-# DEPRECATED contextNewOnHandle "use contextNew" #-} #ifdef INCLUDE_NETWORK
Network/TLS/Context/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Context.Internal -- License : BSD-style@@ -19,6 +20,8 @@ -- * Context object and accessor , Context(..) , Hooks(..)+ , Established(..)+ , PendingAction , ctxEOF , ctxHasSSLv2ClientHello , ctxDisableSSLv2ClientHello@@ -52,12 +55,14 @@ , usingHState , getHState , getStateRNG+ , tls13orLater ) where import Network.TLS.Backend import Network.TLS.Extension import Network.TLS.Cipher import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Compression (Compression) import Network.TLS.State import Network.TLS.Handshake.State@@ -83,6 +88,9 @@ , infoMasterSecret :: Maybe ByteString , infoClientRandom :: Maybe ClientRandom , infoServerRandom :: Maybe ServerRandom+ , infoNegotiatedGroup :: Maybe Group+ , infoTLS13HandshakeMode :: Maybe HandshakeMode13+ , infoIsEarlyDataAccepted :: Bool } deriving (Show,Eq) -- | A TLS Context keep tls specific state, parameters and backend information.@@ -93,7 +101,7 @@ , ctxState :: MVar TLSState , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not.- , ctxEstablished_ :: IORef Bool -- ^ has the handshake been done and been successful.+ , 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@@ -108,8 +116,18 @@ , 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]+ , ctxKeyLogger :: String -> IO () } +data Established = NotEstablished+ | EarlyDataAllowed Int -- remaining 0-RTT bytes allowed+ | EarlyDataNotAllowed Int -- remaining 0-RTT packets allowed to skip+ | Established+ deriving (Eq, Show)++type PendingAction = (Handshake13 -> IO (), IO ())+ updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx f = do x <- readIORef (ctxMeasurement ctx)@@ -118,9 +136,11 @@ withMeasure :: Context -> (Measurement -> IO a) -> IO a withMeasure ctx f = readIORef (ctxMeasurement ctx) >>= f +-- | A shortcut for 'backendFlush . ctxConnection'. contextFlush :: Context -> IO () contextFlush = backendFlush . ctxConnection +-- | A shortcut for 'backendClose . ctxConnection'. contextClose :: Context -> IO () contextClose = backendClose . ctxConnection @@ -129,14 +149,19 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx- let (ms, cr, sr) = case hstate of+ let (ms, cr, sr, hm13, grp) = case hstate of Just st -> (hstMasterSecret st, Just (hstClientRandom st),- hstServerRandom st)- Nothing -> (Nothing, Nothing, Nothing)+ hstServerRandom st,+ if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing,+ hstNegotiatedGroup st)+ Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) (cipher,comp) <- failOnEitherError $ runRxState ctx $ gets $ \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 cr sr+ (Just v, Just c) -> return $ Just $ Information v c comp ms cr sr grp hm13 accepted _ -> return Nothing contextSend :: Context -> ByteString -> IO ()@@ -157,17 +182,17 @@ setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True -ctxEstablished :: Context -> IO Bool+ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx ctxWithHooks :: Context -> (Hooks -> IO a) -> IO a ctxWithHooks ctx f = readIORef (ctxHooks ctx) >>= f contextModifyHooks :: Context -> (Hooks -> Hooks) -> IO ()-contextModifyHooks ctx f = modifyIORef (ctxHooks ctx) f+contextModifyHooks ctx = modifyIORef (ctxHooks ctx) -setEstablished :: Context -> Bool -> IO ()-setEstablished ctx v = writeIORef (ctxEstablished_ ctx) v+setEstablished :: Context -> Established -> IO ()+setEstablished ctx = writeIORef (ctxEstablished_ ctx) withLog :: Context -> (Logging -> IO ()) -> IO () withLog ctx f = ctxWithHooks ctx (f . hookLogging)@@ -191,26 +216,34 @@ usingState_ :: Context -> TLSSt a -> IO a usingState_ ctx f = failOnEitherError $ usingState ctx f -usingHState :: Context -> HandshakeM a -> IO a+usingHState :: MonadIO m => Context -> HandshakeM a -> m a usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> case mst of Nothing -> throwCore $ Error_Misc "missing handshake" Just st -> return $ swap (Just <$> runHandshake st f) -getHState :: Context -> IO (Maybe HandshakeState)+getHState :: MonadIO m => Context -> m (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx) runTxState :: Context -> RecordM a -> IO (Either TLSError a) runTxState ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx)+ hrr <- usingState_ ctx getTLS13HRR+ -- For TLS 1.3, ver' is only used in ClientHello.+ -- 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 modifyMVar (ctxTxState ctx) $ \st ->- case runRecordM f ver st of+ case runRecordM f ver' st of 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. modifyMVar (ctxRxState ctx) $ \st -> case runRecordM f ver st of Left err -> return (st, Left err)@@ -230,3 +263,10 @@ withStateLock :: Context -> IO a -> IO a withStateLock ctx f = withMVar (ctxLockState ctx) (const f)++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
Network/TLS/Core.hs view
@@ -27,41 +27,60 @@ , sendData , recvData , recvData'+ , updateKey+ , KeyUpdateRequest(..) ) where +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.Handshake-import Network.TLS.Util (catchException)+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.KeySchedule+import Network.TLS.Types (Role(..), HostName)+import Network.TLS.Util (catchException, mapChunks_)+import Network.TLS.Extension 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 qualified Control.Exception as E import Control.Monad.State.Strict - -- | notify the context that this side wants to close connection. -- this is important that it is called before closing the handle, otherwise -- the session might not be resumable (for version < TLS1.2). -- -- this doesn't actually close the handle bye :: MonadIO m => Context -> m ()-bye ctx = do- eof <- liftIO $ ctxEOF ctx- unless eof $ sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]+bye ctx = liftIO $ do+ -- Although setEOF is always protected by the read lock, here we don't try+ -- to wrap ctxEOF with it, so that function bye can still be called+ -- concurrently to a blocked recvData.+ eof <- ctxEOF ctx+ tls13 <- tls13orLater ctx+ unless eof $ withWriteLock ctx $+ if tls13 then+ sendPacket13 ctx $ Alert13 [(AlertLevel_Warning, CloseNotify)]+ else+ sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon. getNegotiatedProtocol :: MonadIO m => Context -> m (Maybe B.ByteString) getNegotiatedProtocol ctx = liftIO $ usingState_ ctx S.getNegotiatedProtocol -type HostName = String- -- | If the Server Name Indication extension has been used, return the -- hostname specified by the client. getClientSNI :: MonadIO m => Context -> m (Maybe HostName)@@ -70,60 +89,215 @@ -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size sendData :: MonadIO m => Context -> L.ByteString -> m ()-sendData ctx dataToSend = liftIO (checkValid ctx) >> mapM_ sendDataChunk (L.toChunks dataToSend)- where sendDataChunk d- | B.length d > 16384 = do- let (sending, remain) = B.splitAt 16384 d- sendPacket ctx $ AppData sending- sendDataChunk remain- | otherwise = sendPacket ctx $ AppData d+sendData ctx dataToSend = liftIO $ do+ tls13 <- tls13orLater ctx+ let sendP+ | 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+ -- want to interleave writes from other threads in the middle of our+ -- possibly large write.+ mapM_ (mapChunks_ 16384 sendP) (L.toChunks dataToSend) --- | recvData get data out of Data packet, and automatically renegotiate if--- a Handshake ClientHello is received+-- | Get data out of Data packet, and automatically renegotiate if a Handshake+-- ClientHello is received. An empty result means EOF. recvData :: MonadIO m => Context -> m B.ByteString recvData ctx = liftIO $ do- checkValid ctx- pkt <- withReadLock ctx $ recvPacket ctx- either onError process pkt- where onError Error_EOF = -- Not really an error.- return B.empty-- onError err@(Error_Protocol (reason,fatal,desc)) =- terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason- onError err =- terminate err AlertLevel_Fatal InternalError (show err)+ tls13 <- tls13orLater ctx+ withReadLock ctx $ do+ checkValid ctx+ -- We protect with a read lock both reception and processing of the+ -- packet, because don't want another thread to receive a new packet+ -- before this one has been fully processed.+ --+ -- Even when recvData1/recvData13 loops, we only need to call function+ -- checkValid once. Since we hold the read lock, no concurrent call+ -- will impact the validity of the context.+ if tls13 then recvData13 ctx else recvData1 ctx - process (Handshake [ch@ClientHello{}]) =- handshakeWith ctx ch >> recvData ctx+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 >> recvData ctx+ handshakeWith ctx hr >> recvData1 ctx - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye >> setEOF ctx >> return B.empty+ process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, desc))) -- when receiving empty appdata, we just retry to get some data.- process (AppData "") = recvData ctx+ 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 :: TLSError -> AlertLevel -> AlertDescription -> String -> IO a- terminate err level desc reason = do- session <- usingState_ ctx getSession- case session of- Session Nothing -> return ()- Session (Just sid) -> sessionInvalidate (sharedSessionManager $ ctxShared ctx) sid- catchException (sendPacket ctx $ Alert [(level, desc)]) (\_ -> return ())+ 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, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty+ process (Alert13 [(AlertLevel_Fatal, desc)]) = do setEOF ctx- E.throwIO (Terminated False reason err)+ E.throwIO (Terminated True ("received fatal error: " ++ show desc) (Error_Protocol ("remote side fatal error", True, 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+ 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", True, UnexpectedMessage)+ process ChangeCipherSpec13 = recvData13 ctx+ process p = let reason = "unexpected message " ++ show p 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 = catchException (bye ctx) (\_ -> return ())+ 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+ ResuptionSecret resumptionMasterSecret <- usingHState ctx getTLS13Secret+ (usedHash, usedCipher, _) <- getTxState ctx+ let hashSize = hashDigestSize usedHash+ psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize+ maxSize = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTNewSessionTicket of+ Just (EarlyDataIndication (Just ms)) -> fromIntegral $ safeNonNegative32 ms+ _ -> 0+ tinfo <- createTLS13TicketInfo life (Right add) Nothing+ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk+ sessionEstablish (sharedSessionManager $ ctxShared ctx) label sdata+ -- putStrLn $ "NewSessionTicket received: lifetime = " ++ show life ++ " sec"+ loopHandshake13 hs+ loopHandshake13 (KeyUpdate13 mode:hs) = do+ 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+ -- updated.+ when (mode == UpdateRequested) $ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+ keyUpdate ctx getTxState setTxState+ loopHandshake13 hs+ else do+ let reason = "received key update before established"+ terminate (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ 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 (pa, postAction) -> do+ -- Pending actions are executed with read+write locks, just+ -- like regular handshake code.+ withWriteLock ctx $ do+ pa h+ processHandshake13 ctx h+ postAction+ loopHandshake13 hs + terminate = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13)++-- 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@(Error_Protocol (reason,fatal,desc)) =+ terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason+onError terminate err =+ terminate err AlertLevel_Fatal InternalError (show err)++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 (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 = recvData ctx >>= return . L.fromChunks . (:[])+recvData' ctx = L.fromChunks . (:[]) <$> recvData ctx++keyUpdate :: Context+ -> (Context -> IO (Hash,Cipher,C8.ByteString))+ -> (Context -> Hash -> Cipher -> C8.ByteString -> IO ())+ -> IO ()+keyUpdate ctx getState setState = do+ (usedHash, usedCipher, applicationTrafficSecretN) <- getState ctx+ let applicationTrafficSecretN1 = hkdfExpandLabel usedHash applicationTrafficSecretN "traffic upd" "" $ hashDigestSize usedHash+ setState ctx usedHash usedCipher applicationTrafficSecretN1++-- | How to update keys in TLS 1.3+data KeyUpdateRequest = OneWay -- ^ Unidirectional key update+ | TwoWay -- ^ Bidirectional key update (normal case)+ deriving (Eq, Show)++-- | Updating appication traffic secrets for TLS 1.3.+-- If this API is called for TLS 1.3, 'True' is returned.+-- Otherwise, 'False' is returned.+updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool+updateKey ctx way = liftIO $ do+ tls13 <- tls13orLater ctx+ when tls13 $ do+ let req = case way of+ OneWay -> UpdateNotRequested+ TwoWay -> UpdateRequested+ -- Write lock wraps both actions because we don't want another packet to+ -- be sent by another thread before the Tx state is updated.+ withWriteLock ctx $ do+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]+ keyUpdate ctx getTxState setTxState+ return tls13
Network/TLS/Credentials.hs view
@@ -90,14 +90,14 @@ [] -> Left "no keys found" (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) -credentialsListSigningAlgorithms :: Credentials -> [DigitalSignatureAlg]+credentialsListSigningAlgorithms :: Credentials -> [KeyExchangeSignatureAlg] credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l -credentialsFindForSigning :: DigitalSignatureAlg -> Credentials -> Maybe Credential-credentialsFindForSigning sigAlg (Credentials l) = find forSigning l+credentialsFindForSigning :: KeyExchangeSignatureAlg -> Credentials -> Maybe Credential+credentialsFindForSigning kxsAlg (Credentials l) = find forSigning l where forSigning cred = case credentialCanSign cred of Nothing -> False- Just sig -> sig == sigAlg+ Just kxs -> kxs == kxsAlg credentialsFindForDecrypting :: Credentials -> Maybe Credential credentialsFindForDecrypting (Credentials l) = find forEncrypting l@@ -120,12 +120,12 @@ pub = certPubKey cert signed = getCertificateChainLeaf chain -credentialCanSign :: Credential -> Maybe DigitalSignatureAlg+credentialCanSign :: Credential -> Maybe KeyExchangeSignatureAlg credentialCanSign (chain, priv) = case extensionGet (certExtensions cert) of- Nothing -> findDigitalSignatureAlg (pub, priv)+ Nothing -> findKeyExchangeSignatureAlg (pub, priv) Just (ExtKeyUsage flags)- | KeyUsage_digitalSignature `elem` flags -> findDigitalSignatureAlg (pub, priv)+ | KeyUsage_digitalSignature `elem` flags -> findKeyExchangeSignatureAlg (pub, priv) | otherwise -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert@@ -144,10 +144,13 @@ 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.SignatureRSApssSHA256)- SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA384)- SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssSHA512)+ 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 where convertHash sig X509.HashMD5 = Just (TLS.HashMD5 , sig)@@ -158,10 +161,10 @@ convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) convertHash _ _ = Nothing --- | Checks whether certificates in the chain comply with a list of--- hash/signature algorithm pairs. Currently the verification applies only--- to the leaf certificate, if it is not self-signed. This may be extended--- to additional chain elements in the future.+-- | 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 hashSigs (chain, _) = case chain of
Network/TLS/Crypto.hs view
@@ -26,6 +26,7 @@ , PrivateKey , SignatureParams(..) , findDigitalSignatureAlg+ , findKeyExchangeSignatureAlg , findFiniteFieldGroup , kxEncrypt , kxDecrypt@@ -38,18 +39,20 @@ import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert)+import Crypto.Error import Crypto.Random 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.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 qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS-import Crypto.Number.Serialize (os2ip) -import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..), SerializedPoint(..))+import Data.X509 (PrivKey(..), PubKey(..), PubKeyEC(..))+import Data.X509.EC (ecPubKeyCurveName, unserializePoint) import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types@@ -72,11 +75,23 @@ findDigitalSignatureAlg :: (PubKey, PrivKey) -> Maybe DigitalSignatureAlg findDigitalSignatureAlg keyPair = case keyPair of- (PubKeyRSA _, PrivKeyRSA _) -> Just RSA- (PubKeyDSA _, PrivKeyDSA _) -> Just DSS- --(PubKeyECDSA _, PrivKeyECDSA _) -> Just ECDSA+ (PubKeyRSA _, PrivKeyRSA _) -> Just DS_RSA+ (PubKeyDSA _, PrivKeyDSA _) -> Just DS_DSS+ --(PubKeyECDSA _, PrivKeyECDSA _) -> Just DS_ECDSA+ (PubKeyEd25519 _, PrivKeyEd25519 _) -> Just DS_Ed25519+ (PubKeyEd448 _, PrivKeyEd448 _) -> Just DS_Ed448 _ -> Nothing +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+ findFiniteFieldGroup :: DH.Params -> Maybe Group findFiniteFieldGroup params = lookup (pg params) table where@@ -181,11 +196,13 @@ -- Signature algorithm and associated parameters. ----- FIXME add RSAPSSParams, Ed25519Params, Ed448Params+-- FIXME add RSAPSSParams data SignatureParams = RSAParams Hash RSAEncoding | DSSParams | ECDSAParams Hash+ | Ed25519Params+ | Ed448Params deriving (Show,Eq) -- Verify that the signature matches the given message, using the@@ -213,12 +230,8 @@ Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ do -- get the curve name and the public key data- (curveName, pubBS) <- case key of- PubKeyEC_Named curveName' pub -> Just (curveName',pub)- PubKeyEC_Prime {} ->- case find matchPrimeCurve $ enumFrom $ toEnum 0 of- Nothing -> Nothing- Just curveName' -> Just (curveName', pubkeyEC_pub key)+ let pubBS = pubkeyEC_pub key+ curveName <- ecPubKeyCurveName key -- decode the signature signature <- case decodeASN1' BER sigBS of Left _ -> Nothing@@ -226,7 +239,8 @@ Right _ -> Nothing -- decode the public key related to the curve- pubkey <- unserializePoint (ECC.getCurveByName curveName) pubBS+ let curve = ECC.getCurveByName curveName+ pubkey <- ECDSA.PublicKey curve <$> unserializePoint curve pubBS verifyF <- case alg of MD5 -> Just (ECDSA.verify H.MD5)@@ -237,51 +251,37 @@ SHA512 -> Just (ECDSA.verify H.SHA512) _ -> Nothing return $ verifyF pubkey signature msg- where- matchPrimeCurve c =- case ECC.getCurveByName c of- ECC.CurveFP (ECC.CurvePrime p cc) ->- ECC.ecc_a cc == pubkeyEC_a key &&- ECC.ecc_b cc == pubkeyEC_b key &&- ECC.ecc_n cc == pubkeyEC_order key &&- p == pubkeyEC_prime key- _ -> False-- unserializePoint curve (SerializedPoint bs) =- case B.uncons bs of- Nothing -> Nothing- Just (ptFormat, input) ->- case ptFormat of- 4 -> if B.length input /= 2 * bytes- then Nothing- else- let (x, y) = B.splitAt bytes input- p = ECC.Point (os2ip x) (os2ip y)- in if ECC.isPointValid curve p- then Just $ ECDSA.PublicKey curve p- else Nothing- -- 2 and 3 for compressed format.- _ -> Nothing- where bits = ECC.curveSizeBits curve- bytes = (bits + 7) `div` 8+kxVerify (PubKeyEd25519 key) Ed25519Params msg sigBS =+ case Ed25519.signature sigBS of+ CryptoPassed sig -> Ed25519.verify key msg sig+ _ -> False+kxVerify (PubKeyEd448 key) Ed448Params msg sigBS =+ case Ed448.signature sigBS of+ CryptoPassed sig -> Ed448.verify key msg sig+ _ -> False kxVerify _ _ _ _ = False -- Sign the given message using the private key. -- kxSign :: MonadRandom r => PrivateKey+ -> PublicKey -> SignatureParams -> ByteString -> r (Either KxError ByteString)-kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApkcs1) msg =+kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApkcs1) msg = generalizeRSAError <$> rsaSignHash hashAlg pk msg-kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApss) msg =+kxSign (PrivKeyRSA pk) (PubKeyRSA _) (RSAParams hashAlg RSApss) msg = generalizeRSAError <$> rsapssSignHash hashAlg pk msg-kxSign (PrivKeyDSA pk) DSSParams msg = do+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]-kxSign _ _ _ =+kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg =+ return $ Right $ B.convert $ Ed25519.sign pk pub msg+kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =+ return $ Right $ B.convert $ Ed448.sign pk pub msg+kxSign _ _ _ _ = return (Left KxUnsupported) rsaSignHash :: MonadRandom m => Hash -> RSA.PrivateKey -> ByteString -> m (Either RSA.Error ByteString)
Network/TLS/Crypto/DH.hs view
@@ -12,6 +12,7 @@ , dhParams , dhParamsGetP , dhParamsGetG+ , dhParamsGetBits , dhGenerateKeyPair , dhGetShared , dhValid@@ -66,6 +67,9 @@ dhParamsGetG :: DHParams -> Integer dhParamsGetG (DH.Params _ g _) = g++dhParamsGetBits :: DHParams -> Int+dhParamsGetBits (DH.Params _ _ b) = b dhUnwrapPublic :: DHPublic -> Integer dhUnwrapPublic (DH.PublicNumber y) = y
Network/TLS/Crypto/Types.hs view
@@ -17,10 +17,11 @@ availableECGroups :: [Group] availableECGroups = [P256,P384,P521,X25519,X448] -availableGroups :: [Group]-availableGroups = availableECGroups ++ availableFFGroups---- Digital signature algorithm, in close relation to public/private key types--- and cipher key exchange.-data DigitalSignatureAlg = RSA | DSS | ECDSA | Ed25519 | Ed448+-- Digital signature algorithm, in close relation to public/private key types.+data DigitalSignatureAlg = DS_RSA | DS_DSS | DS_ECDSA | DS_Ed25519 | DS_Ed448 deriving (Show, Eq)++-- Key-exchange signature algorithm, in close relation to ciphers+-- (before TLS 1.3).+data KeyExchangeSignatureAlg = KX_RSA | KX_DSS | KX_ECDSA+ deriving (Show, Eq)
Network/TLS/Extension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} -- | -- Module : Network.TLS.Extension -- License : BSD-style@@ -20,6 +21,16 @@ , 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 -- all implemented extensions , ServerNameType(..) , ServerName(..)@@ -35,18 +46,42 @@ , HeartBeat(..) , HeartBeatMode(..) , SignatureAlgorithms(..)+ , SignatureAlgorithmsCert(..)+ , SupportedVersions(..)+ , KeyShare(..)+ , KeyShareEntry(..)+ , MessageType(..)+ , 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 (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm)+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 (putSignatureHashAlgorithm, getSignatureHashAlgorithm)+import Network.TLS.Packet ( putDNames+ , getDNames+ , putSignatureHashAlgorithm+ , getSignatureHashAlgorithm+ , putBinaryVersion+ , getBinaryVersion+ ) -type HostName = String+------------------------------------------------------------ -- central list defined in <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt> extensionID_ServerName@@ -74,6 +109,16 @@ , 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 extensionID_ServerName = 0x0 -- RFC6066 extensionID_MaxFragmentLength = 0x1 -- RFC6066@@ -88,7 +133,7 @@ extensionID_NegotiatedGroups = 0xa -- RFC4492bis and TLS 1.3 extensionID_EcPointFormats = 0xb -- RFC4492 extensionID_SRP = 0xc -- RFC5054-extensionID_SignatureAlgorithms = 0xd -- RFC5246+extensionID_SignatureAlgorithms = 0xd -- RFC5246, TLS 1.3 extensionID_SRTP = 0xe -- RFC5764 extensionID_Heartbeat = 0xf -- RFC6520 extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301@@ -100,8 +145,22 @@ extensionID_EncryptThenMAC = 0x16 -- RFC7366 extensionID_ExtendedMasterSecret = 0x17 -- draft-ietf-tls-session-hash. expires 2015-09-26 extensionID_SessionTicket = 0x23 -- RFC4507+-- Reserved 0x28 -- TLS 1.3+extensionID_PreSharedKey = 0x29 -- TLS 1.3+extensionID_EarlyData = 0x2a -- TLS 1.3+extensionID_SupportedVersions = 0x2b -- TLS 1.3+extensionID_Cookie = 0x2c -- TLS 1.3+extensionID_PskKeyExchangeModes = 0x2d -- TLS 1.3+-- Reserved 0x2e -- TLS 1.3+extensionID_CertificateAuthorities = 0x2f -- TLS 1.3+extensionID_OidFilters = 0x30 -- TLS 1.3+extensionID_PostHandshakeAuth = 0x31 -- TLS 1.3+extensionID_SignatureAlgorithmsCert = 0x32 -- TLS 1.3+extensionID_KeyShare = 0x33 -- TLS 1.3 extensionID_SecureRenegotiation = 0xff01 -- RFC5746 +------------------------------------------------------------+ definedExtensions :: [ExtensionID] definedExtensions = [ extensionID_ServerName@@ -129,6 +188,14 @@ , extensionID_EncryptThenMAC , extensionID_ExtendedMasterSecret , extensionID_SessionTicket+ , extensionID_PreSharedKey+ , extensionID_EarlyData+ , extensionID_SupportedVersions+ , extensionID_Cookie+ , extensionID_PskKeyExchangeModes+ , extensionID_KeyShare+ , extensionID_SignatureAlgorithmsCert+ , extensionID_CertificateAuthorities , extensionID_SecureRenegotiation ] @@ -141,14 +208,34 @@ , extensionID_NegotiatedGroups , extensionID_EcPointFormats , extensionID_SignatureAlgorithms+ , extensionID_SignatureAlgorithmsCert+ , extensionID_KeyShare+ , extensionID_PreSharedKey+ , extensionID_EarlyData+ , extensionID_SupportedVersions+ , extensionID_Cookie+ , extensionID_PskKeyExchangeModes+ , extensionID_CertificateAuthorities ] +------------------------------------------------------------++data MessageType = MsgTClientHello+ | MsgTServerHello+ | MsgTHelloRetryRequest+ | MsgTEncryptedExtensions+ | MsgTNewSessionTicket+ | MsgTCertificateRequest+ deriving (Eq,Show)+ -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID- extensionDecode :: Bool -> ByteString -> Maybe a+ extensionDecode :: MessageType -> ByteString -> Maybe a extensionEncode :: a -> ByteString +------------------------------------------------------------+ -- | Server Name extension including the name type and the associated name. -- the associated name decoding is dependant of its name type. -- name type = 0 : hostname@@ -163,33 +250,70 @@ extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque- extensionDecode _ = runGetMaybe (getWord16 >>= \len -> ServerName <$> getList (fromIntegral len) getServerName)- where getServerName = do- ty <- getWord8- sname <- getOpaque16- return (1+2+B.length sname, case ty of- 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion- _ -> ServerNameOther (ty, sname))+ extensionDecode MsgTClientHello = decodeServerName+ extensionDecode MsgTServerHello = decodeServerName+ extensionDecode MsgTEncryptedExtensions = decodeServerName+ extensionDecode _ = error "extensionDecode: ServerName" +decodeServerName :: ByteString -> Maybe ServerName+decodeServerName = runGetMaybe $ do+ len <- fromIntegral <$> getWord16+ ServerName <$> getList len getServerName+ where+ getServerName = do+ ty <- getWord8+ snameParsed <- getOpaque16+ let !sname = B.copy snameParsed+ name = case ty of+ 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion+ _ -> ServerNameOther (ty, sname)+ return (1+2+B.length sname, name)++------------------------------------------------------------+ -- | Max fragment extension with length from 512 bytes to 4096 bytes-newtype MaxFragmentLength = MaxFragmentLength MaxFragmentEnum deriving (Show,Eq)-data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096- deriving (Show,Eq)+--+-- RFC 6066 defines:+-- If a server receives a maximum fragment length negotiation request+-- for a value other than the allowed values, it MUST abort the+-- handshake with an "illegal_parameter" alert.+--+-- So, if a server receives MaxFragmentLengthOther, it must send the alert.+data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum+ | MaxFragmentLengthOther Word8+ deriving (Show,Eq) +data MaxFragmentEnum = MaxFragment512+ | MaxFragment1024+ | MaxFragment2048+ | MaxFragment4096+ deriving (Show,Eq)+ instance Extension MaxFragmentLength where extensionID _ = extensionID_MaxFragmentLength- extensionEncode (MaxFragmentLength e) = B.singleton $ marshallSize e- where marshallSize MaxFragment512 = 1- marshallSize MaxFragment1024 = 2- marshallSize MaxFragment2048 = 3- marshallSize MaxFragment4096 = 4- extensionDecode _ = runGetMaybe (MaxFragmentLength . unmarshallSize <$> getWord8)- where unmarshallSize 1 = MaxFragment512- unmarshallSize 2 = MaxFragment1024- unmarshallSize 3 = MaxFragment2048- unmarshallSize 4 = MaxFragment4096- unmarshallSize n = error ("unknown max fragment size " ++ show n)+ extensionEncode (MaxFragmentLength l) = runPut $ putWord8 $ fromMaxFragmentEnum l+ where+ fromMaxFragmentEnum MaxFragment512 = 1+ fromMaxFragmentEnum MaxFragment1024 = 2+ fromMaxFragmentEnum MaxFragment2048 = 3+ fromMaxFragmentEnum MaxFragment4096 = 4+ extensionEncode (MaxFragmentLengthOther l) = runPut $ putWord8 l+ extensionDecode MsgTClientHello = decodeMaxFragmentLength+ extensionDecode MsgTServerHello = decodeMaxFragmentLength+ extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength+ extensionDecode _ = error "extensionDecode: MaxFragmentLength" +decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength+decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8+ where+ toMaxFragmentEnum 1 = MaxFragmentLength MaxFragment512+ toMaxFragmentEnum 2 = MaxFragmentLength MaxFragment1024+ toMaxFragmentEnum 3 = MaxFragmentLength MaxFragment2048+ toMaxFragmentEnum 4 = MaxFragmentLength MaxFragment4096+ toMaxFragmentEnum n = MaxFragmentLengthOther n++------------------------------------------------------------+ -- | Secure Renegotiation data SecureRenegotiation = SecureRenegotiation ByteString (Maybe ByteString) deriving (Show,Eq)@@ -198,13 +322,16 @@ extensionID _ = extensionID_SecureRenegotiation extensionEncode (SecureRenegotiation cvd svd) = runPut $ putOpaque8 (cvd `B.append` fromMaybe B.empty svd)- extensionDecode isServerHello = runGetMaybe $ do+ extensionDecode msgtype = runGetMaybe $ do opaque <- getOpaque8- if isServerHello- then let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque- in return $ SecureRenegotiation cvd (Just svd)- else return $ SecureRenegotiation opaque Nothing+ 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" +------------------------------------------------------------+ -- | Application Layer Protocol Negotiation (ALPN) newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) @@ -212,25 +339,39 @@ extensionID _ = extensionID_ApplicationLayerProtocolNegotiation extensionEncode (ApplicationLayerProtocolNegotiation bytes) = runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes- extensionDecode _ = runGetMaybe (ApplicationLayerProtocolNegotiation <$> getALPN)- where getALPN = do- _ <- getWord16- getALPN'- getALPN' = do- avail <- remaining- case avail of- 0 -> return []- _ -> (:) <$> getOpaque8 <*> getALPN'+ extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation+ extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation+ extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation+ extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation" +decodeApplicationLayerProtocolNegotiation :: ByteString -> Maybe ApplicationLayerProtocolNegotiation+decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do+ len <- getWord16+ ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN+ where+ getALPN = do+ alpnParsed <- getOpaque8+ let !alpn = B.copy alpnParsed+ return (B.length alpn + 1, alpn) +------------------------------------------------------------+ newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where extensionID _ = extensionID_NegotiatedGroups extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups- extensionDecode _ = runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16)+ extensionDecode MsgTClientHello = decodeNegotiatedGroups+ extensionDecode MsgTEncryptedExtensions = decodeNegotiatedGroups+ extensionDecode _ = error "extensionDecode: NegotiatedGroups" +decodeNegotiatedGroups :: ByteString -> Maybe NegotiatedGroups+decodeNegotiatedGroups =+ runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16)++------------------------------------------------------------+ newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) data EcPointFormat =@@ -253,16 +394,30 @@ instance Extension EcPointFormatsSupported where extensionID _ = extensionID_EcPointFormats extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats- extensionDecode _ = runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8)+ extensionDecode MsgTClientHello = decodeEcPointFormatsSupported+ extensionDecode MsgTServerHello = decodeEcPointFormatsSupported+ extensionDecode _ = error "extensionDecode: EcPointFormatsSupported" +decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported+decodeEcPointFormatsSupported =+ runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8)++------------------------------------------------------------++-- Fixme: this is incomplete+-- newtype SessionTicket = SessionTicket ByteString data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket extensionEncode SessionTicket{} = runPut $ return ()- extensionDecode _ = runGetMaybe (return SessionTicket)+ extensionDecode MsgTClientHello = runGetMaybe (return SessionTicket)+ extensionDecode MsgTServerHello = runGetMaybe (return SessionTicket)+ extensionDecode _ = error "extensionDecode: SessionTicket" +------------------------------------------------------------+ newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) data HeartBeatMode =@@ -281,18 +436,231 @@ instance Extension HeartBeat where extensionID _ = extensionID_Heartbeat extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode- extensionDecode _ bs =- case runGetMaybe (toEnumSafe8 <$> getWord8) bs of- Just (Just mode) -> Just $ HeartBeat mode- _ -> Nothing+ extensionDecode MsgTClientHello = decodeHeartBeat+ extensionDecode MsgTServerHello = decodeHeartBeat+ 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"++------------------------------------------------------------+ 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- extensionDecode _ =- runGetMaybe $ do- len <- getWord16- SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))+ extensionDecode MsgTClientHello = decodeSignatureAlgorithms+ extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms+ extensionDecode _ = error "extensionDecode: SignatureAlgorithms"++decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms+decodeSignatureAlgorithms = runGetMaybe $ do+ len <- getWord16+ SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++------------------------------------------------------------++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+ extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert+ extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert+ extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert"++decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert+decodeSignatureAlgorithmsCert = runGetMaybe $ do+ len <- getWord16+ SignatureAlgorithmsCert <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))++------------------------------------------------------------++data SupportedVersions =+ SupportedVersionsClientHello [Version]+ | SupportedVersionsServerHello Version+ deriving (Show,Eq)++instance Extension SupportedVersions where+ extensionID _ = extensionID_SupportedVersions+ extensionEncode (SupportedVersionsClientHello vers) = runPut $ do+ putWord8 (fromIntegral (length vers * 2))+ mapM_ putBinaryVersion vers+ extensionEncode (SupportedVersionsServerHello ver) = runPut $+ putBinaryVersion ver+ extensionDecode MsgTClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord8+ SupportedVersionsClientHello . catMaybes <$> getList len getVer+ where+ getVer = do+ ver <- getBinaryVersion+ return (2,ver)+ extensionDecode MsgTServerHello = runGetMaybe $ do+ mver <- getBinaryVersion+ case mver of+ Just ver -> return $ SupportedVersionsServerHello ver+ Nothing -> fail "extensionDecode: SupportedVersionsServerHello"+ extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"++------------------------------------------------------------++data KeyShareEntry = KeyShareEntry {+ keyShareEntryGroup :: Group+ , keySHareEntryKeyExchange:: ByteString+ } deriving (Show,Eq)++getKeyShareEntry :: Get (Int, Maybe KeyShareEntry)+getKeyShareEntry = do+ g <- getWord16+ l <- fromIntegral <$> getWord16+ key <- getBytes l+ let !len = l + 4+ case toEnumSafe16 g of+ Nothing -> return (len, Nothing)+ Just grp -> return (len, Just $ KeyShareEntry grp key)++putKeyShareEntry :: KeyShareEntry -> Put+putKeyShareEntry (KeyShareEntry grp key) = do+ putWord16 $ fromEnumSafe16 grp+ putWord16 $ fromIntegral $ B.length key+ putBytes key++data KeyShare =+ KeyShareClientHello [KeyShareEntry]+ | KeyShareServerHello KeyShareEntry+ | KeyShareHRR Group+ deriving (Show,Eq)++instance Extension KeyShare where+ extensionID _ = extensionID_KeyShare+ extensionEncode (KeyShareClientHello kses) = runPut $ do+ let !len = sum [B.length key + 4 | KeyShareEntry _ key <- kses]+ putWord16 $ fromIntegral len+ mapM_ putKeyShareEntry kses+ extensionEncode (KeyShareServerHello kse) = runPut $ putKeyShareEntry kse+ extensionEncode (KeyShareHRR grp) = runPut $ putWord16 $ fromEnumSafe16 grp+ extensionDecode MsgTServerHello = runGetMaybe $ do+ (_, ment) <- getKeyShareEntry+ case ment of+ Nothing -> fail "decoding KeyShare for ServerHello"+ Just ent -> return $ KeyShareServerHello ent+ extensionDecode MsgTClientHello = runGetMaybe $ do+ len <- fromIntegral <$> getWord16+ grps <- getList len getKeyShareEntry+ return $ KeyShareClientHello $ catMaybes grps+ extensionDecode MsgTHelloRetryRequest = runGetMaybe $ do+ mgrp <- toEnumSafe16 <$> getWord16+ case mgrp of+ Nothing -> fail "decoding KeyShare for HRR"+ Just grp -> return $ KeyShareHRR grp+ extensionDecode _ = error "extensionDecode: KeyShare"++------------------------------------------------------------++data PskKexMode = PSK_KE | PSK_DHE_KE deriving (Eq, Show)++instance EnumSafe8 PskKexMode where+ 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)++instance Extension PskKeyExchangeModes where+ extensionID _ = extensionID_PskKeyExchangeModes+ 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)++instance Extension PreSharedKey where+ extensionID _ = extensionID_PreSharedKey+ extensionEncode (PreSharedKeyClientHello ids bds) = runPut $ do+ putOpaque16 $ runPut (mapM_ putIdentity ids)+ putOpaque16 $ runPut (mapM_ putBinder bds)+ where+ putIdentity (PskIdentity bs w) = do+ putOpaque16 bs+ putWord32 w+ putBinder = putOpaque8+ extensionEncode (PreSharedKeyServerHello w16) = runPut $+ putWord16 $ fromIntegral w16+ extensionDecode MsgTServerHello = runGetMaybe $+ PreSharedKeyServerHello . fromIntegral <$> getWord16+ extensionDecode MsgTClientHello = runGetMaybe $ do+ len1 <- fromIntegral <$> getWord16+ identities <- getList len1 getIdentity+ len2 <- fromIntegral <$> getWord16+ binders <- getList len2 getBinder+ return $ PreSharedKeyClientHello identities binders+ where+ getIdentity = do+ identity <- getOpaque16+ age <- getWord32+ let len = 2 + B.length identity + 4+ return (len, PskIdentity identity age)+ getBinder = do+ l <- fromIntegral <$> getWord8+ binder <- getBytes l+ let len = l + 1+ return (len, binder)+ extensionDecode _ = error "extensionDecode: PreShareKey"++------------------------------------------------------------++newtype EarlyDataIndication = EarlyDataIndication (Maybe Word32) deriving (Eq, Show)++instance Extension EarlyDataIndication where+ extensionID _ = extensionID_EarlyData+ extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty+ extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32+ extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing)+ extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing)+ extensionDecode MsgTNewSessionTicket = runGetMaybe $+ EarlyDataIndication . Just <$> getWord32+ extensionDecode _ = error "extensionDecode: EarlyDataIndication"++------------------------------------------------------------++newtype Cookie = Cookie ByteString deriving (Eq, Show)++instance Extension Cookie where+ extensionID _ = extensionID_Cookie+ extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque+ extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)+ extensionDecode _ = error "extensionDecode: Cookie"++------------------------------------------------------------++newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName]+ deriving (Eq, Show)++instance Extension CertificateAuthorities where+ extensionID _ = extensionID_CertificateAuthorities+ extensionEncode (CertificateAuthorities names) = runPut $+ putDNames names+ extensionDecode MsgTClientHello =+ runGetMaybe (CertificateAuthorities <$> getDNames)+ extensionDecode MsgTCertificateRequest =+ runGetMaybe (CertificateAuthorities <$> getDNames)+ extensionDecode _ = error "extensionDecode: CertificateAuthorities"
Network/TLS/Extra/Cipher.hs view
@@ -5,7 +5,6 @@ -- Stability : experimental -- Portability : unknown ---{-# LANGUAGE CPP #-} module Network.TLS.Extra.Cipher ( -- * cipher suite@@ -22,7 +21,11 @@ , 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@@ -30,20 +33,37 @@ , cipher_DHE_RSA_AES256_SHA256 , cipher_DHE_DSS_AES128_SHA1 , cipher_DHE_DSS_AES256_SHA1+ , cipher_DHE_RSA_AES128CCM_SHA256+ , cipher_DHE_RSA_AES128CCM8_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256+ , cipher_DHE_RSA_AES256CCM_SHA256+ , cipher_DHE_RSA_AES256CCM8_SHA256 , cipher_DHE_RSA_AES256GCM_SHA384+ , cipher_DHE_RSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256 , cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA256 , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA , cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_ECDSA_AES128CBC_SHA , cipher_ECDHE_ECDSA_AES256CBC_SHA , cipher_ECDHE_ECDSA_AES128CBC_SHA256 , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_ECDSA_AES128CCM_SHA256+ , cipher_ECDHE_ECDSA_AES128CCM8_SHA256 , cipher_ECDHE_ECDSA_AES128GCM_SHA256+ , cipher_ECDHE_ECDSA_AES256CCM_SHA256+ , cipher_ECDHE_ECDSA_AES256CCM8_SHA256 , cipher_ECDHE_ECDSA_AES256GCM_SHA384+ , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256+ -- TLS 1.3+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES256GCM_SHA384+ , cipher_TLS13_CHACHA20POLY1305_SHA256+ , cipher_TLS13_AES128CCM_SHA256+ , cipher_TLS13_AES128CCM8_SHA256 -- * obsolete and non-standard ciphers , cipher_RSA_3DES_EDE_CBC_SHA1 , cipher_RC4_128_MD5@@ -60,10 +80,12 @@ import Data.Tuple (swap) import Crypto.Cipher.AES+import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305 import qualified Crypto.Cipher.RC4 as RC4 import Crypto.Cipher.TripleDES import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error+import qualified Crypto.MAC.Poly1305 as Poly1305 takelast :: Int -> B.ByteString -> B.ByteString takelast i b = B.drop (B.length b - i) b@@ -84,6 +106,34 @@ let ctx = noFail (cipherInit key) :: AES256 in (\iv input -> let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)) +aes128ccm :: BulkDirection -> BulkKey -> BulkAEAD+aes128ccm BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 16)+aes128ccm BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 16)++aes128ccm8 :: BulkDirection -> BulkKey -> BulkAEAD+aes128ccm8 BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 8)+aes128ccm8 BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 8)+ aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD aes128gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES128@@ -94,14 +144,36 @@ let ctx = noFail (cipherInit key) :: AES128 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)- in simpleDecrypt aeadIni ad d)- where- simpleDecrypt aeadIni header input = (output, tag)- where- aead = aeadAppendHeader aeadIni header- (output, aeadFinal) = aeadDecrypt aead input- tag = aeadFinalize aeadFinal 16+ in simpleDecrypt aeadIni ad d 16) +aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD+aes256ccm BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 16)+aes256ccm BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M16 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 16)++aes256ccm8 :: BulkDirection -> BulkKey -> BulkAEAD+aes256ccm8 BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in swap $ aeadSimpleEncrypt aeadIni ad d 8)+aes256ccm8 BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in (\nonce d ad ->+ let mode = AEAD_CCM (B.length d) CCM_M8 CCM_L3+ aeadIni = noFail (aeadInit mode ctx nonce)+ in simpleDecrypt aeadIni ad d 8)+ aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD aes256gcm BulkEncrypt key = let ctx = noFail (cipherInit key) :: AES256@@ -112,13 +184,14 @@ let ctx = noFail (cipherInit key) :: AES256 in (\nonce d ad -> let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)- in simpleDecrypt aeadIni ad d)+ in simpleDecrypt aeadIni ad d 16)++simpleDecrypt :: AEAD cipher -> B.ByteString -> B.ByteString -> Int -> (B.ByteString, AuthTag)+simpleDecrypt aeadIni header input taglen = (output, tag) where- simpleDecrypt aeadIni header input = (output, tag)- where- aead = aeadAppendHeader aeadIni header- (output, aeadFinal) = aeadDecrypt aead input- tag = aeadFinalize aeadFinal 16+ aead = aeadAppendHeader aeadIni header+ (output, aeadFinal) = aeadDecrypt aead input+ tag = aeadFinalize aeadFinal taglen noFail :: CryptoFailable a -> a noFail = throwCryptoError@@ -144,17 +217,43 @@ let (ctx', output) = RC4.combine ctx input in (output, BulkStream (combineRC4 ctx')) --- | All AES ciphers supported ordered from strong to weak. This choice--- of ciphersuites should satisfy most normal needs. For otherwise strong--- ciphers we make little distinction between AES128 and AES256, and list--- each but the weakest of the AES128 ciphers ahead of the corresponding AES256--- ciphers.+chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD+chacha20poly1305 BulkEncrypt key nonce =+ let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key)+ in (\input ad ->+ let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st)+ (output, st3) = ChaChaPoly1305.encrypt input st2+ Poly1305.Auth tag = ChaChaPoly1305.finalize st3+ in (output, AuthTag tag))+chacha20poly1305 BulkDecrypt key nonce =+ let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key)+ in (\input ad ->+ let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st)+ (output, st3) = ChaChaPoly1305.decrypt input st2+ Poly1305.Auth tag = ChaChaPoly1305.finalize st3+ in (output, AuthTag tag))++-- | All AES and ChaCha20-Poly1305 ciphers supported ordered from strong to+-- weak. This choice of ciphersuites should satisfy most normal needs. For+-- otherwise strong ciphers we make little distinction between AES128 and+-- AES256, and list each but the weakest of the AES128 ciphers ahead of the+-- corresponding AES256 ciphers, with the ChaCha20-Poly1305 variant placed just+-- after.+--+-- The CCM ciphers all come together after the GCM variants due to their+-- relative performance cost. ciphersuite_default :: [Cipher] ciphersuite_default = [ -- First the PFS + GCM + SHA2 ciphers cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384+ , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384+ , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384+ , cipher_DHE_RSA_CHACHA20POLY1305_SHA256+ , -- Next the PFS + CCM + SHA2 ciphers+ cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256+ , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256 -- Next the PFS + CBC + SHA2 ciphers , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384@@ -165,6 +264,8 @@ , cipher_DHE_RSA_AES128_SHA1, cipher_DHE_RSA_AES256_SHA1 -- Next the non-PFS + GCM + SHA2 ciphers , cipher_AES128GCM_SHA256, cipher_AES256GCM_SHA384+ -- Next the non-PFS + CCM + SHA2 ciphers+ , cipher_AES128CCM_SHA256, cipher_AES256CCM_SHA256 -- Next the non-PFS + CBC + SHA2 ciphers , cipher_AES256_SHA256, cipher_AES128_SHA256 -- Next the non-PFS + CBC + SHA1 ciphers@@ -173,15 +274,24 @@ -- , 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)+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES256GCM_SHA384+ , cipher_TLS13_CHACHA20POLY1305_SHA256+ , cipher_TLS13_AES128CCM_SHA256 ] {-# WARNING ciphersuite_all "This ciphersuite list contains RC4. Use ciphersuite_strong or ciphersuite_default instead." #-} -- | The default ciphersuites + some not recommended last resort ciphers. ciphersuite_all :: [Cipher] ciphersuite_all = ciphersuite_default ++- [ cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1+ [ 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." #-}@@ -192,14 +302,23 @@ ] -- | The strongest ciphers supported. For ciphers with PFS, AEAD and SHA2, we--- list each AES128 variant right after the corresponding AES256 variant. For--- weaker constructs, we use just the AES256 form.+-- list each AES128 variant after the corresponding AES256 and ChaCha20-Poly1305+-- variants. For weaker constructs, we use just the AES256 form.+--+-- The CCM ciphers come just after the corresponding GCM ciphers despite their+-- relative performance cost. ciphersuite_strong :: [Cipher] ciphersuite_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256- cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_ECDSA_AES128GCM_SHA256- , cipher_ECDHE_RSA_AES256GCM_SHA384, cipher_ECDHE_RSA_AES128GCM_SHA256- , cipher_DHE_RSA_AES256GCM_SHA384, cipher_DHE_RSA_AES128GCM_SHA256+ cipher_ECDHE_ECDSA_AES256GCM_SHA384, cipher_ECDHE_ECDSA_AES256CCM_SHA256+ , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256+ , cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES128CCM_SHA256+ , cipher_ECDHE_RSA_AES256GCM_SHA384+ , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256+ , cipher_ECDHE_RSA_AES128GCM_SHA256+ , 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 -- No AEAD , cipher_ECDHE_ECDSA_AES256CBC_SHA384 , cipher_ECDHE_RSA_AES256CBC_SHA384@@ -210,15 +329,24 @@ , cipher_DHE_RSA_AES256_SHA1 -- No PFS , cipher_AES256GCM_SHA384+ , cipher_AES256CCM_SHA256 -- Neither PFS nor AEAD, just SHA2 , cipher_AES256_SHA256 -- Last resort no PFS, AEAD or SHA2 , cipher_AES256_SHA1+ -- TLS13 (listed at the end but version is negotiated first)+ , cipher_TLS13_AES256GCM_SHA384+ , cipher_TLS13_CHACHA20POLY1305_SHA256+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES128CCM_SHA256 ] --- | DHE-RSA cipher suite+-- | 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_AES128GCM_SHA256+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 ]@@ -231,6 +359,7 @@ 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@@ -263,6 +392,26 @@ , 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@@ -273,6 +422,26 @@ , 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@@ -303,6 +472,16 @@ , 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+ }+ -- | unencrypted cipher using RSA for key exchange and MD5 for digest cipher_null_MD5 :: Cipher cipher_null_MD5 = Cipher@@ -476,6 +655,32 @@ , cipherBulk = bulk_aes256 } +-- | AESCCM cipher (128 bit key), RSA key exchange.+-- The SHA256 digest is used as a PRF, not as a MAC.+cipher_AES128CCM_SHA256 :: Cipher+cipher_AES128CCM_SHA256 = Cipher+ { cipherID = 0xc09c+ , cipherName = "RSA-AES128CCM-SHA256"+ , cipherBulk = bulk_aes128ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }++-- | AESCCM8 cipher (128 bit key), RSA key exchange.+-- The SHA256 digest is used as a PRF, not as a MAC.+cipher_AES128CCM8_SHA256 :: Cipher+cipher_AES128CCM8_SHA256 = Cipher+ { cipherID = 0xc0a0+ , cipherName = "RSA-AES128CCM8-SHA256"+ , cipherBulk = bulk_aes128ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }+ -- | AESGCM cipher (128 bit key), RSA key exchange. -- The SHA256 digest is used as a PRF, not as a MAC. cipher_AES128GCM_SHA256 :: Cipher@@ -489,6 +694,32 @@ , cipherMinVer = Just TLS12 } +-- | AESCCM cipher (256 bit key), RSA key exchange.+-- The SHA256 digest is used as a PRF, not as a MAC.+cipher_AES256CCM_SHA256 :: Cipher+cipher_AES256CCM_SHA256 = Cipher+ { cipherID = 0xc09d+ , cipherName = "RSA-AES256CCM-SHA256"+ , cipherBulk = bulk_aes256ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }++-- | AESCCM8 cipher (256 bit key), RSA key exchange.+-- The SHA256 digest is used as a PRF, not as a MAC.+cipher_AES256CCM8_SHA256 :: Cipher+cipher_AES256CCM8_SHA256 = Cipher+ { cipherID = 0xc0a1+ , cipherName = "RSA-AES256CCM8-SHA256"+ , cipherBulk = bulk_aes256ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }+ -- | AESGCM cipher (256 bit key), RSA key exchange. -- The SHA384 digest is used as a PRF, not as a MAC. cipher_AES256GCM_SHA384 :: Cipher@@ -502,6 +733,28 @@ , cipherMinVer = Just TLS12 } +cipher_DHE_RSA_AES128CCM_SHA256 :: Cipher+cipher_DHE_RSA_AES128CCM_SHA256 = Cipher+ { cipherID = 0xc09e+ , cipherName = "DHE-RSA-AES128CCM-SHA256"+ , cipherBulk = bulk_aes128ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }++cipher_DHE_RSA_AES128CCM8_SHA256 :: Cipher+cipher_DHE_RSA_AES128CCM8_SHA256 = Cipher+ { cipherID = 0xc0a2+ , cipherName = "DHE-RSA-AES128CCM8-SHA256"+ , cipherBulk = bulk_aes128ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }+ cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher cipher_DHE_RSA_AES128GCM_SHA256 = Cipher { cipherID = 0x009E@@ -513,6 +766,28 @@ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4 } +cipher_DHE_RSA_AES256CCM_SHA256 :: Cipher+cipher_DHE_RSA_AES256CCM_SHA256 = Cipher+ { cipherID = 0xc09f+ , cipherName = "DHE-RSA-AES256CCM-SHA256"+ , cipherBulk = bulk_aes256ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }++cipher_DHE_RSA_AES256CCM8_SHA256 :: Cipher+cipher_DHE_RSA_AES256CCM8_SHA256 = Cipher+ { cipherID = 0xc0a3+ , cipherName = "DHE-RSA-AES256CCM8-SHA256"+ , cipherBulk = bulk_aes256ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 6655 Sec 3+ }+ cipher_DHE_RSA_AES256GCM_SHA384 :: Cipher cipher_DHE_RSA_AES256GCM_SHA384 = Cipher { cipherID = 0x009F@@ -524,6 +799,94 @@ , cipherMinVer = Just TLS12 } +cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256 = Cipher+ { cipherID = 0xCCA8+ , cipherName = "ECDHE-RSA-CHACHA20POLY1305-SHA256"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12+ }++cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256 = Cipher+ { cipherID = 0xCCA9+ , cipherName = "ECDHE-ECDSA-CHACHA20POLY1305-SHA256"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12+ }++cipher_DHE_RSA_CHACHA20POLY1305_SHA256 :: Cipher+cipher_DHE_RSA_CHACHA20POLY1305_SHA256 = Cipher+ { cipherID = 0xCCAA+ , cipherName = "DHE-RSA-CHACHA20POLY1305-SHA256"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12+ }++cipher_TLS13_AES128GCM_SHA256 :: Cipher+cipher_TLS13_AES128GCM_SHA256 = Cipher+ { cipherID = 0x1301+ , cipherName = "AES128GCM-SHA256"+ , cipherBulk = bulk_aes128gcm+ , 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+ , cipherHash = SHA384+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++cipher_TLS13_CHACHA20POLY1305_SHA256 :: Cipher+cipher_TLS13_CHACHA20POLY1305_SHA256 = Cipher+ { cipherID = 0x1303+ , cipherName = "CHACHA20POLY1305-SHA256"+ , cipherBulk = bulk_chacha20poly1305+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }++cipher_TLS13_AES128CCM_SHA256 :: Cipher+cipher_TLS13_AES128CCM_SHA256 = Cipher+ { cipherID = 0x1304+ , cipherName = "AES128CCM-SHA256"+ , cipherBulk = bulk_aes128ccm+ , 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+ , cipherHash = SHA256+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_TLS13+ , cipherMinVer = Just TLS13+ }+ cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher cipher_ECDHE_ECDSA_AES128CBC_SHA = Cipher { cipherID = 0xC009@@ -612,6 +975,28 @@ , cipherMinVer = Just TLS12 -- RFC 5289 } +cipher_ECDHE_ECDSA_AES128CCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CCM_SHA256 = Cipher+ { cipherID = 0xc0ac+ , cipherName = "ECDHE-ECDSA-AES128CCM-SHA256"+ , cipherBulk = bulk_aes128ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }++cipher_ECDHE_ECDSA_AES128CCM8_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CCM8_SHA256 = Cipher+ { cipherID = 0xc0ae+ , cipherName = "ECDHE-ECDSA-AES128CCM8-SHA256"+ , cipherBulk = bulk_aes128ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }+ cipher_ECDHE_ECDSA_AES128GCM_SHA256 :: Cipher cipher_ECDHE_ECDSA_AES128GCM_SHA256 = Cipher { cipherID = 0xC02B@@ -621,6 +1006,28 @@ , cipherPRFHash = Just SHA256 , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS12 -- RFC 5289+ }++cipher_ECDHE_ECDSA_AES256CCM_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES256CCM_SHA256 = Cipher+ { cipherID = 0xc0ad+ , cipherName = "ECDHE-ECDSA-AES256CCM-SHA256"+ , cipherBulk = bulk_aes256ccm+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251+ }++cipher_ECDHE_ECDSA_AES256CCM8_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES256CCM8_SHA256 = Cipher+ { cipherID = 0xc0af+ , cipherName = "ECDHE-ECDSA-AES256CCM8-SHA256"+ , cipherBulk = bulk_aes256ccm8+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 7251 } cipher_ECDHE_ECDSA_AES256GCM_SHA384 :: Cipher
Network/TLS/Handshake.hs view
@@ -16,6 +16,7 @@ import Network.TLS.Context.Internal import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.IO import Network.TLS.Util (catchException) import Network.TLS.Imports@@ -25,25 +26,32 @@ import Network.TLS.Handshake.Server import Control.Monad.State.Strict-import Control.Exception (IOException, catch, fromException)+import Control.Exception (IOException, handle, fromException) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation handshake :: MonadIO m => Context -> m () handshake ctx =- liftIO $ handleException ctx $ withRWLock ctx (ctxDoHandshake ctx ctx)+ liftIO $ withRWLock ctx $ handleException ctx (ctxDoHandshake ctx ctx) -- Handshake when requested by the remote end--- This is called automatically by 'recvData'+-- This is called automatically by 'recvData', in a context where the read lock+-- is already taken. So contrary to 'handshake' above, here we only need to+-- call withWriteLock. handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs =- liftIO $ handleException ctx $ withRWLock ctx $ ctxDoHandshakeWith ctx ctx hs+ liftIO $ withWriteLock ctx $ handleException ctx $ ctxDoHandshakeWith ctx ctx hs handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception- setEstablished ctx False- sendPacket ctx (errorToAlert tlserror) `catch` ignoreIOErr+ setEstablished ctx NotEstablished+ handle ignoreIOErr $ do+ tls13 <- tls13orLater ctx+ if tls13 then+ sendPacket13 ctx $ Alert13 $ errorToAlert tlserror+ else+ sendPacket ctx $ Alert $ errorToAlert tlserror handshakeFailed tlserror where ignoreIOErr :: IOException -> IO ()
Network/TLS/Handshake/Certificate.hs view
@@ -7,7 +7,9 @@ -- module Network.TLS.Handshake.Certificate ( certificateRejected+ , badCertificate , rejectOnException+ , verifyLeafKeyUsage ) where import Network.TLS.Context.Internal@@ -15,6 +17,7 @@ import Network.TLS.X509 import Control.Monad.State.Strict import Control.Exception (SomeException)+import Data.X509 (ExtKeyUsage(..), ExtKeyUsageFlag, extensionGet, getSigned, signedObject) -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected :: MonadIO m => CertificateRejectReason -> m a@@ -27,5 +30,20 @@ certificateRejected (CertificateRejectOther s) = throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) +badCertificate :: MonadIO m => String -> m a+badCertificate msg = throwCore $ Error_Protocol (msg, True, BadCertificate)+ 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+ where+ cert = signedObject $ getSigned signed+ verified =+ case extensionGet (certExtensions cert) of+ Nothing -> True -- unrestricted cert+ Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags
Network/TLS/Handshake/Client.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client@@ -15,30 +16,37 @@ import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression-import Network.TLS.Packet+import Network.TLS.Credentials+import Network.TLS.Packet hiding (getExtensions) import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.IO import Network.TLS.Imports-import Network.TLS.State hiding (getNegotiatedProtocol)+import Network.TLS.State import Network.TLS.Measurement-import Network.TLS.Wire (encodeWord16)-import Network.TLS.Util (bytesEq, catchException)+import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) import Network.TLS.Types import Network.TLS.X509 import qualified Data.ByteString as B+import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict import Control.Exception (SomeException) import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Random import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.KeySchedule+import Network.TLS.Wire handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx@@ -48,18 +56,61 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do+ let groups = case clientWantSessionResume cparams of+ Nothing -> groupsSupported+ Just (_, sdata) -> case sessionGroup sdata of+ Nothing -> [] -- TLS 1.2 or earlier+ Just grp -> grp : filter (/= grp) groupsSupported+ groupsSupported = supportedGroups (ctxSupported ctx)+ handshakeClient' cparams ctx groups Nothing++-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says:+-- "The client will also send a+-- ClientHello when the server has responded to its ClientHello with a+-- HelloRetryRequest. In that case, the client MUST send the same+-- ClientHello without modification, except as follows:"+--+-- So, the ClientRandom in the first client hello is necessary.+handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO ()+handshakeClient' cparams ctx groups mcrand = do updateMeasure ctx incrementNbHandshakes- sentExtensions <- sendClientHello+ sentExtensions <- sendClientHello mcrand recvServerHello sentExtensions- sessionResuming <- usingState_ ctx isSessionResuming- if sessionResuming- then sendChangeCipherAndFinish ctx ClientRole- else do sendClientData cparams ctx- sendChangeCipherAndFinish ctx ClientRole- recvChangeCipherAndFinish ctx- handshakeTerminate ctx+ ver <- usingState_ ctx getVersion+ -- 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 do+ if hrr then case drop 1 groups of+ [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter)+ groups' -> do+ 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 }+ crand <- usingHState ctx $ hstClientRandom <$> get+ handshakeClient' cparams' ctx [selectedGroup] (Just crand)+ | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter)+ Just _ -> error "handshakeClient': invalid KeyShare value"+ Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure)+ else do+ handshakeClient13 cparams ctx+ else do+ 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 getExtensions = sequence [sniExtension ,secureReneg ,alpnExtension@@ -68,6 +119,12 @@ --,sessionTicketExtension ,signatureAlgExtension -- ,heartbeatExtension+ ,versionExtension+ ,earlyDataExtension+ ,keyshareExtension+ ,pskExchangeModeExtension+ ,cookieExtension+ ,preSharedKeyExtension -- MUST be last ] toExtensionRaw :: Extension e => e -> ExtensionRaw@@ -98,23 +155,124 @@ signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams - sendClientHello = do- crand <- ClientRandom <$> getStateRNG ctx 32- let clientSession = Session . (fst <$>) $ clientWantSessionResume cparams- highestVer = maximum $ supportedVersions $ ctxSupported ctx- extensions <- catMaybes <$> getExtensions- startHandshake ctx highestVer crand+ versionExtension+ | tls13 = do+ let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx+ return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers+ | otherwise = return Nothing++ -- FIXME+ keyshareExtension+ | tls13 = case groups of+ [] -> return Nothing+ 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)++ preSharedKeyExtension =+ case sessionAndCipherToResume13 of+ Nothing -> return Nothing+ Just (sid, sdata, sCipher) -> do+ let usedHash = cipherHash sCipher+ siz = hashDigestSize usedHash+ zero = B.replicate siz 0+ tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata+ age <- getAge tinfo+ if isAgeValid age tinfo then do+ let obfAge = ageToObfuscatedAge age tinfo+ let identity = PskIdentity sid obfAge+ offeredPsks = PreSharedKeyClientHello [identity] [zero]+ return $ Just $ toExtensionRaw offeredPsks+ else+ return Nothing++ pskExchangeModeExtension+ | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]+ | otherwise = return Nothing++ earlyDataExtension = case check0RTT of+ Nothing -> return Nothing+ _ -> return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)++ cookieExtension = do+ mcookie <- usingState_ ctx getTLS13Cookie+ case mcookie of+ Nothing -> return Nothing+ Just cookie -> return $ Just $ toExtensionRaw cookie++ clientSession = case clientWantSessionResume cparams of+ Nothing -> Session Nothing+ Just (sid, sdata)+ | sessionVersion sdata >= TLS13 -> Session Nothing+ | otherwise -> Session (Just sid)++ adjustExtentions exts ch =+ case sessionAndCipherToResume13 of+ Nothing -> return exts+ Just (_, sdata, sCipher) -> do+ let usedHash = cipherHash sCipher+ siz = hashDigestSize usedHash+ zero = B.replicate siz 0+ psk = sessionSecret sdata+ earlySecret = hkdfExtract usedHash zero psk+ usingHState ctx $ setTLS13Secret (EarlySecret earlySecret)+ let ech = encodeHandshake ch+ binder <- makePSKBinder ctx earlySecret usedHash (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'++ sendClientHello mcr = do+ crand <- clientRandom ctx mcr+ let ver = if tls13 then TLS12 else highestVer+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer- sendPacket ctx $ Handshake- [ ClientHello highestVer crand clientSession (map cipherID ciphers)- (map compressionID compressions) extensions Nothing- ]+ let cipherIds = map cipherID ciphers+ compIds = map compressionID compressions+ mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing+ extensions0 <- catMaybes <$> getExtensions+ extensions <- adjustExtentions extensions0 $ mkClientHello extensions0+ sendPacket ctx $ Handshake [mkClientHello extensions]+ send0RTT return $ map (\(ExtensionRaw i _) -> i) extensions + check0RTT = do+ (_, sdata, sCipher) <- sessionAndCipherToResume13+ earlyData <- clientEarlyData cparams+ guard (B.length earlyData <= sessionMaxEarlyDataSize sdata)+ return (sCipher, earlyData)++ send0RTT = case check0RTT of+ Nothing -> return ()+ Just (usedCipher, earlyData) -> do+ let usedHash = cipherHash usedCipher+ -- fixme: not initialized yet+ -- hCh <- transcriptHash ctx+ hmsgs <- usingHState ctx getHandshakeMessages+ let hCh = hash usedHash $ B.concat hmsgs -- fixme+ EarlySecret earlySecret <- usingHState ctx getTLS13Secret -- fixme+ let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh+ logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)+ setTxState ctx usedHash usedCipher clientEarlyTrafficSecret+ mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData+ usingHState ctx $ setTLS13RTT0Status RTT0Sent+ recvServerHello sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of- Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs+ Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs -- this adds SH to hstHandshakeMessages Alert a -> case a of [(AlertLevel_Warning, UnrecognizedName)] ->@@ -125,43 +283,173 @@ _ -> fail ("unexepected type received. expecting handshake and got: " ++ show p) throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) --- | send client Data after receiving all server data (hello/certificates/key).+-- | Store the keypair and check that it is compatible with a list of+-- 'CertificateType' values.+storePrivInfoClient :: Context+ -> [CertificateType]+ -> Credential+ -> IO ()+storePrivInfoClient ctx cTypes (cc, privkey) = do+ privalg <- storePrivInfo ctx cc privkey+ unless (certificateCompatible privalg cTypes) $+ throwCore $ Error_Protocol+ ( show privalg ++ " credential does not match allowed certificate types"+ , True+ , InternalError )++-- | When the server requests a client certificate, we try to+-- obtain a suitable certificate chain and private key via the+-- callback in the client parameters. It is OK for the callback+-- to return an empty chain, in many cases the client certificate+-- is optional. If the client wishes to abort the handshake for+-- lack of a suitable certificate, it can throw an exception in+-- the callback. --+-- The return value is 'Nothing' when no @CertificateRequest@ was+-- received and no @Certificate@ message needs to be sent. An empty+-- chain means that an empty @Certificate@ message needs to be sent+-- to the server, naturally without a @CertificateVerify@. A non-empty+-- 'CertificateChain' is the chain to send to the server along with+-- a corresponding 'CertificateVerify'.+--+-- With TLS < 1.2 the server's @CertificateRequest@ does not carry+-- a signature algorithm list. It has a list of supported public+-- key signing algorithms in the @certificate_types@ field. The+-- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA.+--+-- With TLS == 1.2 the server's @CertificateRequest@ always has a+-- @supported_signature_algorithms@ list, as a fixed component of+-- the structure. This list is (wrongly) overloaded to also limit+-- X.509 signatures in the client's certificate chain. The BCP+-- strategy is to find a compatible chain if possible, but else+-- ignore the constraint, and let the server verify the chain as it+-- sees fit. The @supported_signature_algorithms@ field is only+-- obligatory with respect to signatures on TLS messages, in this+-- case the @CertificateVerify@ message. The @certificate_types@+-- field is still included.+--+-- With TLS 1.3 the server's @CertificateRequest@ has a mandatory+-- @signature_algorithms@ extension, the @signature_algorithms_cert@+-- extension, which is optional, carries a list of algorithms the+-- server promises to support in verifying the certificate chain.+-- As with TLS 1.2, the client's makes a /best-effort/ to deliver+-- a compatible certificate chain where all the CA signatures are+-- known to be supported, but it should not abort the connection+-- just because the chain might not work out, just send the best+-- chain you have and let the server worry about the rest. The+-- supported public key algorithms are now inferred from the+-- @signature_algorithms@ extension and @certificate_types@ is+-- gone.+--+-- With TLS 1.3, we synthesize and store a @certificate_types@+-- field at the time that the server's @CertificateRequest@+-- message is received. This is then present across all the+-- protocol versions, and can be used to determine whether+-- a @CertificateRequest@ was received or not.+--+-- If @signature_algorithms@ is 'Nothing', then we're doing+-- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension+-- is optional in TLS 1.3, and so the application callback+-- will not be able to distinguish between TLS 1.[01] and+-- TLS 1.3 with no certificate algorithm hints, but this+-- just simplifies the chain selection process, all CA+-- signatures are OK.+--+clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)+clientChain cparams ctx =+ usingHState ctx getCertReqCBdata >>= \case+ Nothing -> return Nothing+ Just cbdata -> do+ let callback = onCertificateRequest $ clientHooks cparams+ chain <- liftIO $ callback cbdata `catchException`+ throwMiscErrorOnException "certificate request callback failed"+ case chain of+ Nothing+ -> return $ Just $ CertificateChain []+ Just (CertificateChain [], _)+ -> return $ Just $ CertificateChain []+ Just cred@(cc, _)+ -> do+ let (cTypes, _, _) = cbdata+ storePrivInfoClient ctx cTypes cred+ return $ Just cc++-- | Return a most preferred 'HandAndSignatureAlgorithm' that is+-- compatible with the private key and server's signature+-- algorithms (both already saved). Must only be called for TLS+-- versions 1.2 and up.+--+-- 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+ -> [HashAndSignatureAlgorithm]+ -> DigitalSignatureAlg+ -> IO HashAndSignatureAlgorithm+getLocalHashSigAlg ctx cHashSigs keyAlg = do+ -- Must be present with TLS 1.2 and up.+ (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata+ let want = (&&) <$> signatureCompatible keyAlg+ <*> flip elem hashSigs+ case find want cHashSigs of+ Just best -> return best+ Nothing -> throwCore $ Error_Protocol+ ( keyerr keyAlg+ , True+ , HandshakeFailure+ )+ where+ keyerr alg = "no " ++ show alg ++ " hash algorithm in common with the server"++-- | Return the supported 'CertificateType' values that are+-- compatible with at least one supported signature algorithm.+--+supportedCtypes :: [HashAndSignatureAlgorithm]+ -> [CertificateType]+supportedCtypes hashAlgs =+ nub $ foldr ctfilter [] hashAlgs+ where+ ctfilter x acc = case hashSigToCertType x of+ Just cType | cType <= lastSupportedCertificateType+ -> cType : acc+ _ -> acc+--+clientSupportedCtypes :: Context+ -> [CertificateType]+clientSupportedCtypes ctx =+ supportedCtypes $ supportedHashSignatures $ ctxSupported ctx+--+sigAlgsToCertTypes :: Context+ -> [HashAndSignatureAlgorithm]+ -> [CertificateType]+sigAlgsToCertTypes ctx hashSigs =+ filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx++-- | TLS 1.2 and below. Send the client handshake messages that+-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@.+--+-- XXX: Is any buffering done here to combined these messages into+-- a single TCP packet? Otherwise we're prone to Nagle delays, or+-- in any case needlessly generate multiple small packets, where+-- a single larger packet will do. The TLS 1.3 code path seems+-- to separating record generation and transmission and sending+-- multiple records in a single packet.+-- -- -> [certificate] -- -> client key exchange -- -> [cert verify] sendClientData :: ClientParams -> Context -> IO () sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify where- -- When the server requests a client certificate, we- -- fetch a certificate chain from the callback in the- -- client parameters and send it to the server.- -- Additionally, we store the private key associated- -- with the first certificate in the chain for later- -- use.- -- sendCertificate = do- certRequested <- usingHState ctx getClientCertRequest- case certRequested of- Nothing ->- return ()-- Just req -> do- certChain <- liftIO $ (onCertificateRequest $ clientHooks cparams) req `catchException`- throwMiscErrorOnException "certificate request callback failed"-- usingHState ctx $ setClientCertSent False- case certChain of- Nothing -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])]- Just (CertificateChain [], _) -> sendPacket ctx $ Handshake [Certificates (CertificateChain [])]- Just (cc@(CertificateChain (c:_)), pk) -> do- case certPubKey $ getCertificate c of- PubKeyRSA _ -> return ()- PubKeyDSA _ -> return ()- _ -> throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure)- usingHState ctx $ setPrivateKey pk- usingHState ctx $ setClientCertSent True- sendPacket ctx $ Handshake [Certificates cc]+ 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@@ -171,7 +459,8 @@ (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let premaster = encodePreMasterSecret clientVersion prerand- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ logKey ctx (MasterSecret masterSecret) 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.@@ -195,37 +484,46 @@ 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", True, InsufficientSecurity)+ GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)+ GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)+ 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- 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", True, InsufficientSecurity)- GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)- GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)- GroupUsageValid -> do- (clientDHPriv, clientDHPub) <- generateDHE ctx params- let premaster = dhGetShared params clientDHPriv srvpub- return (clientDHPub, premaster)+ (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 public key", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure) Just pair -> return pair - usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster-+ masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ logKey ctx (MasterSecret masterSecret) return $ CKX_DH clientDHPub getCKX_ECDHE = do- ServerECDHParams _grp srvpub <- usingHState ctx getServerECDHParams+ 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 public key", True, HandshakeFailure)+ Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ logKey ctx (MasterSecret masterSecret) return $ CKX_ECDH $ encodeGroupPublic clipub -- In order to send a proper certificate verify message,@@ -238,49 +536,41 @@ -- 4. Send it to the server. -- sendCertificateVerify = do- usedVersion <- usingState_ ctx getVersion+ 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- sigAlg <- getLocalSignatureAlg-- mhashSig <- case usedVersion of- TLS12 -> do- Just (_, Just hashSigs, _) <- usingHState ctx getClientCertRequest- -- The values in the "signature_algorithms" extension- -- are in descending order of preference.- -- However here the algorithms are selected according- -- to client preference in 'supportedHashSignatures'.- let suppHashSigs = supportedHashSignatures $ ctxSupported ctx- matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs- hashSigs' = filter (`elem` hashSigs) matchHashSigs-- when (null hashSigs') $- throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure)- return $ Just $ head hashSigs'+ keyAlg <- getLocalDigitalSignatureAlg ctx+ mhashSig <- case ver of+ TLS12 ->+ let cHashSigs = supportedHashSignatures $ ctxSupported ctx+ in Just <$> getLocalHashSigAlg ctx cHashSigs keyAlg _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages- sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs+ sigDig <- createCertificateVerify ctx ver keyAlg mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] - getLocalSignatureAlg = do- pk <- usingHState ctx getLocalPrivateKey- case pk of- PrivKeyRSA _ -> return RSA- PrivKeyDSA _ -> return DSS- processServerExtension :: ExtensionRaw -> TLSSt ()-processServerExtension (ExtensionRaw 0xff01 content) = 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", True, HandshakeFailure)- return ()+processServerExtension (ExtensionRaw extID content)+ | extID == extensionID_SecureRenegotiation = do+ cv <- getVerifiedData ClientRole+ sv <- getVerifiedData ServerRole+ let bs = extensionEncode (SecureRenegotiation cv $ Just sv)+ unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)+ | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of+ Just (SupportedVersionsServerHello ver) -> setVersion ver+ _ -> return ()+ | extID == extensionID_KeyShare = do+ hrr <- getTLS13HRR+ let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello+ setTLS13KeyShare $ extensionDecode msgt content+ | extID == extensionID_PreSharedKey =+ setTLS13PreSharedKey $ extensionDecode MsgTServerHello content processServerExtension _ = return () throwMiscErrorOnException :: String -> SomeException -> IO a@@ -298,9 +588,6 @@ onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)- case find (== rver) (supportedVersions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion)- Just _ -> return () -- 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", True, HandshakeFailure)@@ -311,51 +598,85 @@ -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail.- unless (null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) exts) $+ let checkExt (ExtensionRaw i _)+ | i == extensionID_Cookie = False -- for HRR+ | otherwise = i `notElem` sentExts+ when (any checkExt exts) $ throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) let resumingSession = case clientWantSessionResume cparams of Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing Nothing -> Nothing+ isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do+ setTLS13HRR isHRR+ setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello) setSession serverSession (isJust resumingSession)+ setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts- setVersion rver- usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - case extensionDecode False <$> extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts of- Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do- mprotos <- getClientALPNSuggest- case mprotos of- Just protos -> when (proto `elem` protos) $ do- setExtensionALPN True- setNegotiatedProtocol proto- _ -> return ()- _ -> return ()+ setALPN ctx exts - case resumingSession of- Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx)- Just sessionData -> do- usingHState ctx (setMasterSecret rver ClientRole $ sessionSecret sessionData)- return $ RecvStateNext expectChangeCipher+ ver <- usingState_ ctx getVersion++ -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3+ -- in the supported_versions extension, *AND ALSO* set the TLS 1.2+ -- downgrade signal in the server random. If we support TLS 1.3 and+ -- actually negotiate TLS 1.3, we must ignore the server random downgrade+ -- signal. Therefore, 'isDowngraded' needs to take into account the+ -- negotiated version and the server random, as well as the list of+ -- client-side enabled protocol versions.+ --+ when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $+ throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter)++ case find (== ver) (supportedVersions $ ctxSupported ctx) of+ Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion)+ Just _ -> return ()+ if ver > TLS12 then do+ ensureNullCompression compression+ usingHState ctx $ setHelloParameters13 cipherAlg+ return RecvStateDone+ else do+ usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg+ case resumingSession of+ Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx)+ Just sessionData -> do+ 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 -- run certificate recv hook- ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs)+ ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of- CertificateUsageAccept -> return ()+ 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+ 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)@@ -373,14 +694,14 @@ return $ RecvStateHandshake (processCertificateRequest ctx) where processWithCipher cipher skx = case (cipherKeyExchange cipher, skx) of- (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> do- doDHESignature dhparams signature RSA- (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do- doDHESignature dhparams signature DSS- (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> do- doECDHESignature ecdhparams signature RSA- (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> do- doECDHESignature ecdhparams signature ECDSA+ (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@@ -388,30 +709,288 @@ 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, True, HandshakeFailure)- doDHESignature dhparams signature signatureType = do- -- FIXME verify if FF group is one of supported groups+ doDHESignature dhparams signature kxsAlg = do+ -- FF group selected by the server is verified when generating CKX+ signatureType <- getSignatureType kxsAlg verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature- unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure)+ unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams) usingHState ctx $ setServerDHParams dhparams - doECDHESignature ecdhparams signature signatureType = do- -- FIXME verify if EC group is one of supported groups+ doECDHESignature ecdhparams signature kxsAlg = do+ -- EC group selected by the server is verified when generating CKX+ signatureType <- getSignatureType kxsAlg verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature- unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure)+ unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for ecdhparams") usingHState ctx $ setServerECDHParams ecdhparams + getSignatureType kxsAlg = do+ publicKey <- usingHState ctx getRemotePublicKey+ case (kxsAlg, publicKey) of+ (KX_RSA, PubKeyRSA _) -> return DS_RSA+ (KX_DSS, PubKeyDSA _) -> return DS_DSS+ (KX_ECDSA, PubKeyEC _) -> return DS_ECDSA+ (KX_ECDSA, PubKeyEd25519 _) -> return DS_Ed25519+ (KX_ECDSA, PubKeyEd448 _) -> return DS_Ed448+ _ -> throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure)+ processServerKeyExchange ctx p = processCertificateRequest ctx p processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)-processCertificateRequest ctx (CertRequest cTypes sigAlgs dNames) = do- -- When the server requests a client- -- certificate, we simply store the- -- information for later.- --- usingHState ctx $ setClientCertRequest (cTypes, sigAlgs, dNames)+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"+ , True+ , InternalError+ )+ let cTypes = filter (<= lastSupportedCertificateType) cTypesSent+ usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) return $ RecvStateHandshake (processServerHelloDone ctx)-processCertificateRequest ctx p = processServerHelloDone ctx p+processCertificateRequest ctx p = do+ usingHState ctx $ setCertReqCBdata Nothing+ processServerHelloDone ctx p processServerHelloDone :: Context -> Handshake -> IO (RecvState m) processServerHelloDone _ ServerHelloDone = return RecvStateDone processServerHelloDone _ p = unexpected (show p) (Just "server hello data")++-- Unless result is empty, server certificate must be allowed for at least one+-- of the returned values. Constraints for RSA-based key exchange are relaxed+-- to avoid rejecting certificates having incomplete extension.+requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]+requiredCertKeyUsage cipher =+ case cipherKeyExchange cipher of+ CipherKeyExchange_RSA -> rsaCompatibility+ CipherKeyExchange_DH_Anon -> [] -- unrestricted+ CipherKeyExchange_DHE_RSA -> rsaCompatibility+ CipherKeyExchange_ECDHE_RSA -> rsaCompatibility+ CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ]+ CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ]+ CipherKeyExchange_DH_RSA -> rsaCompatibility+ CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ]+ CipherKeyExchange_ECDH_RSA -> rsaCompatibility+ CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ]+ CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ]+ where rsaCompatibility = [ KeyUsage_digitalSignature+ , KeyUsage_keyEncipherment+ , KeyUsage_keyAgreement+ ]++handshakeClient13 :: ClientParams -> Context -> IO ()+handshakeClient13 _cparams ctx = do+ usedCipher <- usingHState ctx getPendingCipher+ let usedHash = cipherHash usedCipher+ handshakeClient13' _cparams ctx usedCipher usedHash++handshakeClient13' :: ClientParams -> Context -> Cipher -> Hash -> IO ()+handshakeClient13' cparams ctx usedCipher usedHash = do+ (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret+ rtt0accepted <- runRecvHandshake13 $ do+ accepted <- recvHandshake13preUpdate ctx expectEncryptedExtensions+ unless resuming $ recvHandshake13preUpdate ctx expectCertRequest+ recvFinished serverHandshakeTrafficSecret+ return accepted+ hChSf <- transcriptHash ctx+ when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+ setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret+ chain <- clientChain cparams ctx+ runPacketFlight ctx $ do+ case chain of+ Nothing -> return ()+ Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc+ rawFinished <- makeFinished ctx usedHash clientHandshakeTrafficSecret+ loadPacket13 ctx $ Handshake13 [rawFinished]+ masterSecret <- switchToTrafficSecret handshakeSecret hChSf+ setResumptionSecret masterSecret+ setEstablished ctx Established+ where+ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0++ sendClientData13 chain (Just token) = do+ let (CertificateChain certs) = chain+ certExts = replicate (length certs) []+ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]+ case certs of+ [] -> return ()+ _ -> do+ hChSc <- transcriptHash ctx+ keyAlg <- getLocalDigitalSignatureAlg ctx+ sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs keyAlg+ vfy <- makeCertVerify ctx keyAlg sigAlg hChSc+ loadPacket13 ctx $ Handshake13 [vfy]+ --+ sendClientData13 _ _ =+ throwCore $ Error_Protocol+ ( "missing TLS 1.3 certificate request context token"+ , True+ , InternalError+ )++ switchToHandshakeSecret = do+ ecdhe <- calcSharedKey+ (earlySecret, resuming) <- makeEarlySecret+ let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe+ hChSh <- transcriptHash ctx+ let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh+ serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh+ logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret)+ logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret)+ setRxState ctx usedHash usedCipher serverHandshakeTrafficSecret+ return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret)++ switchToTrafficSecret handshakeSecret hChSf = do+ let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero+ let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf+ serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf+ exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf+ usingState_ ctx $ setExporterMasterSecret exporterMasterSecret+ logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0)+ logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0)+ setTxState ctx usedHash usedCipher clientApplicationTrafficSecret0+ setRxState ctx usedHash usedCipher serverApplicationTrafficSecret0+ return masterSecret++ calcSharedKey = do+ serverKeyShare <- do+ mks <- usingState_ ctx getTLS13KeyShare+ case mks of+ Just (KeyShareServerHello ks) -> return ks+ Just _ -> error "calcSharedKey: invalid KeyShare value"+ Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure)+ let grp = keyShareEntryGroup serverKeyShare+ checkSupportedGroup ctx grp+ usingHState ctx $ setNegotiatedGroup grp+ usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare++ makeEarlySecret = do+ secret <- usingHState ctx getTLS13Secret+ case secret of+ EarlySecret sec -> do+ mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey+ case mSelectedIdentity of+ Nothing ->+ return (hkdfExtract usedHash zero zero, False)+ Just (PreSharedKeyServerHello 0) -> do+ usingHState ctx $ setTLS13HandshakeMode PreSharedKey+ return (sec, True)+ Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)+ _ -> return (hkdfExtract usedHash zero zero, False)++ expectEncryptedExtensions (EncryptedExtensions13 eexts) = do+ liftIO $ setALPN ctx 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+ Nothing -> do+ usingHState ctx $ setTLS13HandshakeMode RTT0+ usingHState ctx $ setTLS13RTT0Status RTT0Rejected+ return False+ else+ return False+ expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions")++ expectCertRequest (CertRequest13 token exts) = do+ let hsextID = extensionID_SignatureAlgorithms+ -- caextID = extensionID_SignatureAlgorithmsCert+ dNames <- canames+ -- The @signature_algorithms@ extension is mandatory.+ hsAlgs <- extalgs hsextID unsighash+ cTypes <- case hsAlgs of+ Just as ->+ let validAs = filter isHashSignatureValid13 as+ in return $ sigAlgsToCertTypes ctx validAs+ Nothing -> throwCore $ Error_Protocol+ ( "invalid certificate request"+ , True+ , HandshakeFailure )+ -- Unused:+ -- caAlgs <- extalgs caextID uncertsig+ usingHState ctx $ do+ setCertReqToken $ Just token+ setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)+ -- setCertReqSigAlgsCert caAlgs+ recvHandshake13preUpdate ctx expectCertAndVerify+ where+ canames = case extensionLookup+ extensionID_CertificateAuthorities exts of+ Nothing -> return []+ Just ext -> case extensionDecode MsgTCertificateRequest ext of+ Just (CertificateAuthorities names) -> return names+ _ -> throwCore $ Error_Protocol+ ( "invalid certificate request"+ , True+ , 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"+ , True+ , HandshakeFailure )++ unsighash :: SignatureAlgorithms+ -> Maybe [HashAndSignatureAlgorithm]+ unsighash (SignatureAlgorithms a) = Just a++ {- Unused for now+ uncertsig :: SignatureAlgorithmsCert+ -> Maybe [HashAndSignatureAlgorithm]+ uncertsig (SignatureAlgorithmsCert a) = Just a+ -}++ expectCertRequest other = do+ usingHState ctx $ do+ setCertReqToken Nothing+ setCertReqCBdata Nothing+ -- setCertReqSigAlgsCert Nothing+ expectCertAndVerify other++ expectCertAndVerify (Certificate13 _ cc@(CertificateChain certChain) _) = do+ _ <- liftIO $ processCertificate cparams ctx (Certificates cc)+ pubkey <- case certChain of+ [] -> throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)+ c:_ -> return $ certPubKey $ getCertificate c+ usingHState ctx $ setPublicKey pubkey+ hChSc <- transcriptHash ctx+ recvHandshake13preUpdate ctx $ expectCertVerify pubkey hChSc+ expectCertAndVerify p = unexpected (show p) (Just "server certificate")++ expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do+ let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)+ ok <- checkCertVerify ctx keyAlg sigAlg sig hChSc+ unless ok $ decryptError "cannot verify CertificateVerify"+ expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify")++ recvFinished serverHandshakeTrafficSecret = do+ hChSv <- transcriptHash ctx+ let verifyData' = makeVerifyData usedHash serverHandshakeTrafficSecret hChSv+ recvHandshake13preUpdate ctx $ expectFinished verifyData'++ expectFinished verifyData' (Finished13 verifyData) =+ when (verifyData' /= verifyData) $ decryptError "cannot verify finished"+ expectFinished _ p = unexpected (show p) (Just "server finished")++ setResumptionSecret masterSecret = do+ hChCf <- transcriptHash ctx+ let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf+ usingHState ctx $ setTLS13Secret $ ResuptionSecret resumptionMasterSecret++setALPN :: Context -> [ExtensionRaw] -> IO ()+setALPN ctx exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTServerHello of+ Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do+ mprotos <- getClientALPNSuggest+ case mprotos of+ Just protos -> when (proto `elem` protos) $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ _ -> return ()+ _ -> return ()
Network/TLS/Handshake/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed@@ -14,6 +15,10 @@ , recvPacketHandshake , onRecvStateHandshake , extensionLookup+ , getSessionData+ , storePrivInfo+ , isSupportedGroup+ , checkSupportedGroup ) where import Control.Concurrent.MVar@@ -24,14 +29,16 @@ import Network.TLS.Session import Network.TLS.Struct import Network.TLS.IO-import Network.TLS.State hiding (getNegotiatedProtocol)+import Network.TLS.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.State import Network.TLS.Record.State import Network.TLS.Measurement import Network.TLS.Types import Network.TLS.Cipher+import Network.TLS.Crypto import Network.TLS.Util+import Network.TLS.X509 import Network.TLS.Imports import Control.Monad.State.Strict@@ -40,11 +47,11 @@ handshakeFailed :: TLSError -> IO () handshakeFailed err = throwIO $ HandshakeFailed err -errorToAlert :: TLSError -> Packet-errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)]-errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]+errorToAlert :: TLSError -> [(AlertLevel, AlertDescription)]+errorToAlert (Error_Protocol (_, _, ad)) = [(AlertLevel_Fatal, ad)]+errorToAlert _ = [(AlertLevel_Fatal, InternalError)] -unexpected :: String -> Maybe String -> IO a+unexpected :: MonadIO m => String -> Maybe String -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session@@ -70,10 +77,11 @@ return $ Just (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake)) { hstServerRandom = hstServerRandom hshake , hstMasterSecret = hstMasterSecret hshake+ , hstNegotiatedGroup = hstNegotiatedGroup hshake } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running.- setEstablished ctx True+ setEstablished ctx Established return () sendChangeCipherAndFinish :: Context@@ -103,12 +111,22 @@ pkts <- recvPacket ctx case pkts of Right (Handshake l) -> return l+ Right x@(AppData _) -> do+ -- If a TLS13 server decides to reject RTT0 data, the server should+ -- skip records for RTT0 data up to the maximum limit.+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed n+ | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1)+ recvPacketHandshake ctx+ _ -> fail ("unexpected type received. expecting handshake and got: " ++ show x) Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x) 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 nstate <- f x processHandshake ctx x@@ -126,16 +144,55 @@ sni <- usingState_ ctx getClientSNI mms <- usingHState ctx (gets hstMasterSecret) tx <- liftIO $ readMVar (ctxTxState ctx)+ alpn <- usingState_ ctx getNegotiatedProtocol+ let !cipher = cipherID $ fromJust "cipher" $ stCipher tx+ !compression = compressionID $ stCompression tx case mms of Nothing -> return Nothing Just ms -> return $ Just SessionData { sessionVersion = ver- , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx- , sessionCompression = compressionID $ stCompression tx+ , sessionCipher = cipher+ , sessionCompression = compression , sessionClientSNI = sni , sessionSecret = ms+ , sessionGroup = Nothing+ , sessionTicketInfo = Nothing+ , sessionALPN = alpn+ , sessionMaxEarlyDataSize = 0 } extensionLookup :: ExtensionID -> [ExtensionRaw] -> Maybe ByteString extensionLookup toFind = fmap (\(ExtensionRaw _ content) -> content) . find (\(ExtensionRaw eid _) -> eid == toFind)++-- | Store the specified keypair. Whether the public key and private key+-- actually match is left for the peer to discover. We're not presently+-- burning CPU to detect that misconfiguration. We verify only that the+-- types of keys match.+storePrivInfo :: MonadIO m+ => Context+ -> CertificateChain+ -> PrivKey+ -> m DigitalSignatureAlg+storePrivInfo ctx cc privkey = do+ let CertificateChain (c:_) = cc+ pubkey = certPubKey $ getCertificate c+ privalg <- case findDigitalSignatureAlg (pubkey, privkey) of+ Just alg -> return alg+ Nothing -> throwCore $ Error_Protocol+ ( "mismatched or unsupported private key pair"+ , True+ , InternalError )+ usingHState ctx $ setPublicPrivateKeys (pubkey, privkey)+ return privalg++-- verify that the group selected by the peer is supported in the local+-- configuration+checkSupportedGroup :: Context -> Group -> IO ()+checkSupportedGroup ctx grp =+ unless (isSupportedGroup ctx grp) $+ let msg = "unsupported (EC)DHE group: " ++ show grp+ in throwCore $ Error_Protocol (msg, True, IllegalParameter)++isSupportedGroup :: Context -> Group -> Bool+isSupportedGroup ctx grp = grp `elem` supportedGroups (ctxSupported ctx)
+ Network/TLS/Handshake/Common13.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-}++-- |+-- Module : Network.TLS.Handshake.Common13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Handshake.Common13+ ( makeFinished+ , makeVerifyData+ , makeServerKeyShare+ , makeClientKeyShare+ , fromServerKeyShare+ , makeCertVerify+ , checkCertVerify+ , makePSKBinder+ , replacePSKBinder+ , createTLS13TicketInfo+ , ageToObfuscatedAge+ , isAgeValid+ , getAge+ , checkFreshness+ , getCurrentTimeFromBase+ , getSessionData13+ , ensureNullCompression+ , isHashSignatureValid13+ , safeNonNegative32+ , RecvHandshake13M+ , runRecvHandshake13+ , recvHandshake13preUpdate+ , recvHandshake13postUpdate+ ) where++import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Data.Hourglass+import Network.TLS.Compression+import Network.TLS.Context.Internal+import Network.TLS.Cipher+import Network.TLS.Crypto+import qualified Network.TLS.Crypto.IES as IES+import Network.TLS.Extension+import Network.TLS.Handshake.Process (processHandshake13)+import Network.TLS.Handshake.Common (unexpected)+import Network.TLS.Handshake.Key+import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.Handshake.Signature+import Network.TLS.Imports+import Network.TLS.KeySchedule+import Network.TLS.MAC+import Network.TLS.IO+import Network.TLS.State+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Types+import Network.TLS.Wire+import Time.System++import Control.Monad.State.Strict++----------------------------------------------------------------++makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished ctx usedHash baseKey =+ Finished13 . makeVerifyData usedHash baseKey <$> transcriptHash ctx++makeVerifyData :: Hash -> ByteString -> ByteString -> ByteString+makeVerifyData usedHash baseKey hashValue = hmac usedHash finishedKey hashValue+ where+ hashSize = hashDigestSize usedHash+ finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize++----------------------------------------------------------------++makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)+makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of+ Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure)+ Right cpub -> do+ ecdhePair <- generateECDHEShared ctx cpub+ case ecdhePair of+ Nothing -> throwCore $ Error_Protocol (msgInvalidPublic, True, HandshakeFailure)+ 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 server " ++ show grp ++ " public key"++makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)+makeClientKeyShare ctx grp = do+ (cpri, cpub) <- generateECDHE ctx grp+ let wcpub = IES.encodeGroupPublic cpub+ clientKeyShare = KeyShareEntry grp wcpub+ return (cpri, clientKeyShare)++fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString+fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of+ Left e -> throwCore $ Error_Protocol (show e, True, HandshakeFailure)+ 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", True, HandshakeFailure)+ where+ espub = IES.decodeGroupPublic grp wspub++----------------------------------------------------------------++serverContextString :: ByteString+serverContextString = "TLS 1.3, server CertificateVerify"++clientContextString :: ByteString+clientContextString = "TLS 1.3, client CertificateVerify"++makeCertVerify :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> ByteString -> m Handshake13+makeCertVerify ctx sig hs hashValue = do+ cc <- liftIO $ usingState_ ctx isClientContext+ let ctxStr | cc == ClientRole = clientContextString+ | otherwise = serverContextString+ target = makeTarget ctxStr hashValue+ CertVerify13 hs <$> sign ctx sig hs target++checkCertVerify :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Signature -> ByteString -> m Bool+checkCertVerify ctx sig hs signature hashValue = liftIO $ do+ cc <- usingState_ ctx isClientContext+ let ctxStr | cc == ClientRole = serverContextString -- opposite context+ | otherwise = clientContextString+ target = makeTarget ctxStr hashValue+ sigParams = signatureParams sig (Just hs)+ checkHashSignatureValid13 hs+ checkSupportedHashSignature ctx (Just hs)+ verifyPublic ctx sigParams target signature++makeTarget :: ByteString -> ByteString -> ByteString+makeTarget contextString hashValue = runPut $ do+ putBytes $ B.replicate 64 32+ putBytes contextString+ putWord8 0+ putBytes hashValue++sign :: MonadIO m => Context -> DigitalSignatureAlg -> HashAndSignatureAlgorithm -> ByteString -> m Signature+sign ctx sig hs target = liftIO $ do+ cc <- usingState_ ctx isClientContext+ let sigParams = signatureParams sig (Just hs)+ signPrivate ctx cc sigParams target++----------------------------------------------------------------++makePSKBinder :: Context -> ByteString -> Hash -> Int -> Maybe ByteString -> IO ByteString+makePSKBinder ctx earlySecret usedHash truncLen mch = do+ rmsgs0 <- usingHState ctx getHandshakeMessagesRev -- fixme+ let rmsgs = case mch of+ Just ch -> trunc ch : rmsgs0+ Nothing -> trunc (head rmsgs0) : tail rmsgs0+ hChTruncated = hash usedHash $ B.concat $ reverse rmsgs+ binderKey = deriveSecret usedHash earlySecret "res binder" (hash usedHash "")+ return $ makeVerifyData usedHash binderKey hChTruncated+ where+ trunc x = B.take takeLen x+ where+ totalLen = B.length x+ takeLen = totalLen - truncLen++replacePSKBinder :: ByteString -> ByteString -> ByteString+replacePSKBinder pskz binder = identities `B.append` binders+ where+ bindersSize = B.length binder + 3+ identities = B.take (B.length pskz - bindersSize) pskz+ binders = runPut $ putOpaque16 $ runPut $ putOpaque8 binder++----------------------------------------------------------------++createTLS13TicketInfo :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo+createTLS13TicketInfo life ecw mrtt = do+ -- Left: serverSendTime+ -- Right: clientReceiveTime+ bTime <- getCurrentTimeFromBase+ add <- case ecw of+ Left ctx -> B.foldl' (*+) 0 <$> getStateRNG ctx 4+ Right ad -> return ad+ return $ TLS13TicketInfo life add bTime mrtt+ where+ x *+ y = x * 256 + fromIntegral y++ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second+ageToObfuscatedAge age tinfo = obfage+ where+ !obfage = age + ageAdd tinfo++obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second+obfuscatedAgeToAge obfage tinfo = age+ where+ !age = obfage - ageAdd tinfo++isAgeValid :: Second -> TLS13TicketInfo -> Bool+isAgeValid age tinfo = age <= lifetime tinfo * 1000++getAge :: TLS13TicketInfo -> IO Second+getAge tinfo = do+ let clientReceiveTime = txrxTime tinfo+ clientSendTime <- getCurrentTimeFromBase+ return $! fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds++checkFreshness :: TLS13TicketInfo -> Second -> IO Bool+checkFreshness tinfo obfAge = do+ serverReceiveTime <- getCurrentTimeFromBase+ let freshness = if expectedArrivalTime > serverReceiveTime+ then expectedArrivalTime - serverReceiveTime+ else serverReceiveTime - expectedArrivalTime+ -- Some implementations round age up to second.+ -- We take max of 2000 and rtt in the case where rtt is too small.+ let tolerance = max 2000 rtt+ isFresh = freshness < tolerance+ return $ isAlive && isFresh+ where+ serverSendTime = txrxTime tinfo+ Just rtt = estimatedRTT tinfo+ age = obfuscatedAgeToAge obfAge tinfo+ expectedArrivalTime = serverSendTime + rtt + fromIntegral age+ isAlive = isAgeValid age tinfo++getCurrentTimeFromBase :: IO Millisecond+getCurrentTimeFromBase = millisecondsFromBase <$> timeCurrentP++millisecondsFromBase :: ElapsedP -> Millisecond+millisecondsFromBase d = fromIntegral ms+ where+ ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns) = d - timeConvert base+ ms = s * 1000 + ns `div` 1000000+ base = Date 2017 January 1++----------------------------------------------------------------++getSessionData13 :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData+getSessionData13 ctx usedCipher tinfo maxSize psk = do+ 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+ }++----------------------------------------------------------------++ensureNullCompression :: MonadIO m => CompressionID -> m ()+ensureNullCompression compression =+ when (compression /= compressionID nullCompression) $+ throwCore $ Error_Protocol ("compression is not allowed in TLS 1.3", True, IllegalParameter)++-- Word32 is used in TLS 1.3 protocol.+-- Int is used for API for Haskell TLS because it is natural.+-- If Int is 64 bits, users can specify bigger number than Word32.+-- If Int is 32 bits, 2^31 or larger may be converted into minus numbers.+safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a+safeNonNegative32 x+ | x <= 0 = 0+ | finiteBitSize x <= 32 = x+ | otherwise = x `min` fromIntegral (maxBound :: Word32)+----------------------------------------------------------------++newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+ deriving (Functor, Applicative, Monad, MonadIO)++recvHandshake13preUpdate :: MonadIO m+ => Context+ -> (Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+recvHandshake13preUpdate ctx f = do+ h <- getHandshake13 ctx+ liftIO $ processHandshake13 ctx h+ f h++recvHandshake13postUpdate :: MonadIO m+ => Context+ -> (Handshake13 -> RecvHandshake13M m a)+ -> RecvHandshake13M m a+recvHandshake13postUpdate ctx f = do+ h <- getHandshake13 ctx+ v <- f h+ liftIO $ processHandshake13 ctx h+ return v++getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13+getHandshake13 ctx = RecvHandshake13M $ do+ currentState <- get+ case currentState of+ (h:hs) -> found h hs+ [] -> recvLoop+ where+ found h hs = put hs >> return h+ recvLoop = do+ epkt <- recvPacket13 ctx+ case epkt of+ Right (Handshake13 []) -> recvLoop+ 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+ (result, new) <- runStateT f []+ unless (null new) $ unexpected "spurious handshake 13" Nothing+ return result++----------------------------------------------------------------++-- some hash/signature combinations have been deprecated in TLS13 and should+-- not be used+checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()+checkHashSignatureValid13 hs =+ unless (isHashSignatureValid13 hs) $+ let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs+ in throwCore $ Error_Protocol (msg, True, IllegalParameter)++isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 (HashIntrinsic, s) =+ s `elem` [ SignatureRSApssRSAeSHA256+ , SignatureRSApssRSAeSHA384+ , SignatureRSApssRSAeSHA512+ , SignatureEd25519+ , SignatureEd448+ , SignatureRSApsspssSHA256+ , SignatureRSApsspssSHA384+ , SignatureRSApsspssSHA512+ ]+isHashSignatureValid13 (h, SignatureECDSA) =+ h `elem` [ HashSHA256, HashSHA384, HashSHA512 ]+isHashSignatureValid13 _ = False
Network/TLS/Handshake/Key.hs view
@@ -17,8 +17,13 @@ , generateECDHEShared , generateFFDHE , generateFFDHEShared+ , getLocalDigitalSignatureAlg+ , logKey+ , LogKey(..) ) where +import Control.Monad.State.Strict+ import qualified Data.ByteString as B import Network.TLS.Handshake.State@@ -27,6 +32,7 @@ import Network.TLS.Types import Network.TLS.Context.Internal import Network.TLS.Imports+import Network.TLS.Struct {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem.@@ -37,28 +43,28 @@ usingState_ ctx $ do v <- withRNG $ kxEncrypt publicKey content case v of- Left err -> fail ("rsa encrypt failed: " ++ show err)+ Left err -> error ("rsa encrypt failed: " ++ show err) Right econtent -> return econtent signPrivate :: Context -> Role -> SignatureParams -> ByteString -> IO ByteString signPrivate ctx _ params content = do- privateKey <- usingHState ctx getLocalPrivateKey+ (publicKey, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do- r <- withRNG $ kxSign privateKey params content+ r <- withRNG $ kxSign privateKey publicKey params content case r of- Left err -> fail ("sign failed: " ++ show err)+ Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString) decryptRSA ctx econtent = do- privateKey <- usingHState ctx getLocalPrivateKey+ (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do ver <- getVersion let cipher = if ver < TLS10 then econtent else B.drop 2 econtent withRNG $ kxDecrypt privateKey cipher -verifyPublic :: Context -> Role -> SignatureParams -> ByteString -> ByteString -> IO Bool-verifyPublic ctx _ params econtent sign = do+verifyPublic :: Context -> SignatureParams -> ByteString -> ByteString -> IO Bool+verifyPublic ctx params econtent sign = do publicKey <- usingHState ctx getRemotePublicKey return $ kxVerify publicKey params econtent sign @@ -76,3 +82,47 @@ generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey)) generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub++getLocalDigitalSignatureAlg :: (MonadFail m, MonadIO m) => Context -> m DigitalSignatureAlg+getLocalDigitalSignatureAlg ctx = do+ keys <- usingHState ctx getLocalPublicPrivateKeys+ case findDigitalSignatureAlg keys of+ Just sigAlg -> return sigAlg+ Nothing -> fail "selected credential does not support signing"++----------------------------------------------------------------++data LogKey = MasterSecret ByteString+ | ClientEarlyTrafficSecret ByteString+ | ServerHandshakeTrafficSecret ByteString+ | ClientHandshakeTrafficSecret ByteString+ | ServerTrafficSecret0 ByteString+ | ClientTrafficSecret0 ByteString++labelAndKey :: LogKey -> (String, ByteString)+labelAndKey (MasterSecret key) =+ ("CLIENT_RANDOM", key)+labelAndKey (ClientEarlyTrafficSecret key) =+ ("CLIENT_EARLY_TRAFFIC_SECRET", key)+labelAndKey (ServerHandshakeTrafficSecret key) =+ ("SERVER_HANDSHAKE_TRAFFIC_SECRET", key)+labelAndKey (ClientHandshakeTrafficSecret key) =+ ("CLIENT_HANDSHAKE_TRAFFIC_SECRET", key)+labelAndKey (ServerTrafficSecret0 key) =+ ("SERVER_TRAFFIC_SECRET_0", key)+labelAndKey (ClientTrafficSecret0 key) =+ ("CLIENT_TRAFFIC_SECRET_0", key)++-- NSS Key Log Format+-- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format+logKey :: Context -> LogKey -> 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+ where+ dump = init . tail . showBytesHex
Network/TLS/Handshake/Process.hs view
@@ -9,6 +9,7 @@ -- module Network.TLS.Handshake.Process ( processHandshake+ , processHandshake13 , startHandshake , getHandshakeDigest ) where@@ -22,14 +23,19 @@ import Network.TLS.Packet import Network.TLS.ErrT import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.State import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Imports+import Network.TLS.Handshake.Random+import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13 import Network.TLS.Handshake.Key import Network.TLS.Extension import Network.TLS.Parameters+import Network.TLS.Sending13 import Data.X509 (CertificateChain(..), Certificate(..), getCertificate) processHandshake :: Context -> Handshake -> IO ()@@ -42,13 +48,15 @@ -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF} when (secureRenegotiation && (0xff `elem` cids)) $ usingState_ ctx $ setSecureRenegotiation True- startHandshake ctx cver ran+ hrr <- usingState_ ctx getTLS13HRR+ unless hrr $ startHandshake ctx cver ran Certificates certs -> processCertificates role certs ClientKeyXchg content -> when (role == ServerRole) $ do processClientKeyXchg ctx content Finished fdata -> processClientFinished ctx fdata _ -> return () let encoded = encodeHandshake hs+ when (isHRR hs) $ usingHState ctx wrapAsMessageHash13 when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded when (finishHandshakeTypeMaterial $ typeOfHandshake hs) $ usingHState ctx $ updateHandshakeDigest encoded where secureRenegotiation = supportedSecureRenegotiation $ ctxSupported ctx@@ -71,6 +79,12 @@ usingHState ctx $ setPublicKey pubkey where pubkey = certPubKey $ getCertificate c + isHRR (ServerHello TLS12 srand _ _ _ _) = isHelloRetryRequest srand+ isHRR _ = False++processHandshake13 :: Context -> Handshake13 -> IO ()+processHandshake13 = updateHandshake13+ -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negotiated version. -- in case the version mismatch, generate a random master secret@@ -79,7 +93,7 @@ (rver, role, random) <- usingState_ ctx $ do (,,) <$> getVersion <*> isClientContext <*> genRandom 48 ePremaster <- decryptRSA ctx encryptedPremaster- usingHState ctx $ do+ masterSecret <- usingHState ctx $ do expectedVer <- gets hstClientVersion case ePremaster of Left _ -> setMasterSecretFromPre rver role random@@ -88,6 +102,8 @@ Right (ver, _) | ver /= expectedVer -> setMasterSecretFromPre rver role random | otherwise -> setMasterSecretFromPre rver role premaster+ liftIO $ logKey ctx (MasterSecret masterSecret)+ processClientKeyXchg ctx (CKX_DH clientDHValue) = do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext@@ -99,27 +115,28 @@ dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared params dhpriv clientDHValue- usingHState ctx $ setMasterSecretFromPre rver role premaster+ 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", True, HandshakeFailure) Right clipub -> do- srvpri <- usingHState ctx getECDHPrivate+ srvpri <- usingHState ctx getGroupPrivate case groupGetShared clipub srvpri of Just premaster -> do rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext- usingHState ctx $ setMasterSecretFromPre rver role premaster- Nothing -> throwCore $ Error_Protocol ("cannote generate a shared secret on ECDH", True, HandshakeFailure)+ masterSecret <- usingHState ctx $ setMasterSecretFromPre rver role premaster+ liftIO $ logKey ctx (MasterSecret masterSecret)+ Nothing -> throwCore $ Error_Protocol ("cannot generate a shared secret on ECDH", True, HandshakeFailure) processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion expected <- usingHState ctx $ getHandshakeDigest ver $ invertRole cc- when (expected /= fdata) $ do- throwCore $ Error_Protocol("bad record mac", True, BadRecordMac)+ when (expected /= fdata) $ decryptError "cannot verify finished" usingState_ ctx $ updateVerifiedData ServerRole fdata return ()
+ Network/TLS/Handshake/Random.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE PatternGuards #-}+-- |+-- Module : Network.TLS.Handshake.Random+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Handshake.Random (+ serverRandom+ , clientRandom+ , hrrRandom+ , isHelloRetryRequest+ , isDowngraded+ ) where++import qualified Data.ByteString as B+import Network.TLS.Context.Internal+import Network.TLS.Struct++-- | Generate a server random suitable for the version selected by the server+-- and its supported versions. We use an 8-byte downgrade suffix when the+-- selected version is lowered because of incomplete client support, but also+-- when a version downgrade has been forced with 'debugVersionForced'. This+-- second part allows to test that the client implementation correctly detects+-- downgrades. The suffix is not used when forcing TLS13 to a server not+-- officially supporting TLS13 (this is not a downgrade scenario but only the+-- 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+ where+ genServRand suff = do+ pref <- getStateRNG ctx 24+ return (pref `B.append` suff)++-- | Test if the negotiated version was artificially downgraded (that is, for+-- other reason than the versions supported by the client).+isDowngraded :: Version -> [Version] -> ServerRandom -> Bool+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++suffix12 :: B.ByteString+suffix12 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x01]++suffix11 :: B.ByteString+suffix11 = B.pack [0x44, 0x4F, 0x57, 0x4E, 0x47, 0x52, 0x44, 0x00]++-- ClientRandom in the second client hello for retry must be+-- the same as the first one.+clientRandom :: Context -> Maybe ClientRandom -> IO ClientRandom+clientRandom ctx Nothing = ClientRandom <$> getStateRNG ctx 32+clientRandom _ (Just cr) = return cr++hrrRandom :: ServerRandom+hrrRandom = ServerRandom $ B.pack [+ 0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11+ , 0xBE, 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91+ , 0xC2, 0xA2, 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E+ , 0x07, 0x9E, 0x09, 0xE2, 0xC8, 0xA8, 0x33, 0x9C+ ]++isHelloRetryRequest :: ServerRandom -> Bool+isHelloRetryRequest = (== hrrRandom)
Network/TLS/Handshake/Server.hs view
@@ -16,20 +16,23 @@ import Network.TLS.Context.Internal import Network.TLS.Session import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Crypto import Network.TLS.Extension-import Network.TLS.Util (catchException, fromJust)+import Network.TLS.Util (bytesEq, catchException, fromJust) import Network.TLS.IO import Network.TLS.Types-import Network.TLS.State hiding (getNegotiatedProtocol)+import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key+import Network.TLS.Handshake.Random import Network.TLS.Measurement import qualified Data.ByteString as B+import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict @@ -37,6 +40,9 @@ import Network.TLS.Handshake.Common import Network.TLS.Handshake.Certificate import Network.TLS.X509+import Network.TLS.Handshake.State13+import Network.TLS.KeySchedule+import Network.TLS.Handshake.Common13 -- Put the server context in handshake mode. --@@ -77,11 +83,15 @@ -- handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () handshakeServerWith sparams ctx clientHello@(ClientHello clientVersion _ 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", False, NoRenegotiation) -- rejecting client initiated renegotiation to prevent DOS. unless (supportedClientInitiatedRenegotiation (ctxSupported ctx)) $ do- established <- ctxEstablished ctx eof <- ctxEOF ctx- when (established && not eof) $+ when (established == Established && not eof) $ throwCore $ Error_Protocol ("renegotiation is not allowed", False, NoRenegotiation) -- check if policy allow this new handshake to happens handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)@@ -100,25 +110,67 @@ -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) && (0x5600 `elem` ciphers) &&- clientVersion /= maxBound) $+ clientVersion < TLS12) $ throwCore $ Error_Protocol ("fallback is not allowed", True, InappropriateFallback)- chosenVersion <- case findHighestVersionFrom clientVersion (supportedVersions $ ctxSupported ctx) of- Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)- Just v -> return v-- -- If compression is null, commonCompressions should be [0].- when (null commonCompressions) $ throwCore $- Error_Protocol ("no compression in common with the client", True, HandshakeFailure)+ -- choosing TLS version+ let clientVersions = case extensionLookup extensionID_SupportedVersions exts >>= extensionDecode MsgTClientHello of+ Just (SupportedVersionsClientHello vers) -> vers+ _ -> []+ serverVersions = supportedVersions $ ctxSupported ctx+ mVersion = debugVersionForced $ serverDebug sparams+ chosenVersion <- case mVersion of+ Just cver -> return cver+ Nothing ->+ if (TLS13 `elem` serverVersions) && clientVersion == TLS12 && clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of+ Nothing -> throwCore $ Error_Protocol ("client versions " ++ show clientVersions ++ " is not supported", True, ProtocolVersion)+ Just v -> return v+ else case findHighestVersionFrom clientVersion serverVersions of+ Nothing -> throwCore $ Error_Protocol ("client version " ++ show clientVersion ++ " is not supported", True, ProtocolVersion)+ Just v -> return v -- SNI (Server Name Indication)- let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode False of+ let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode MsgTClientHello of Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing _ -> Nothing+ maybe (return ()) (usingState_ ctx . setClientSNI) serverName - extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName+ -- ALPN (Application Layer Protocol Negotiation)+ case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTClientHello of+ Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos+ _ -> return () + extraCreds <- onServerNameIndication (serverHooks sparams) serverName+ let allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx)++ -- TLS version dependent+ if chosenVersion <= TLS12 then+ handshakeServerWithTLS12 sparams ctx chosenVersion allCreds 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 allCreds exts ciphers serverName clientSession+handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)++-- TLS 1.2 or earlier+handshakeServerWithTLS12 :: ServerParams+ -> Context+ -> Version+ -> Credentials+ -> [ExtensionRaw]+ -> [CipherID]+ -> Maybe String+ -> Version+ -> [CompressionID]+ -> Session+ -> IO ()+handshakeServerWithTLS12 sparams ctx chosenVersion allCreds exts ciphers serverName clientVersion compressions clientSession = do+ -- If compression is null, commonCompressions should be [0].+ when (null commonCompressions) $ throwCore $+ Error_Protocol ("no compression in common with the client", True, HandshakeFailure)+ -- When selecting a cipher we must ensure that it is allowed for the -- TLS version but also that all its key-exchange requirements -- will be met.@@ -155,7 +207,6 @@ cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) - allCreds = extraCreds `mappend` sharedCredentials (ctxShared ctx) (creds, signatureCreds, ciphersFilteredVersion) = case chosenVersion of TLS12 -> let -- Build a list of all hash/signature algorithms in common between@@ -177,7 +228,7 @@ -- -- 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 TLS 1.3 section 4.4.2.2).+ -- (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.@@ -199,14 +250,15 @@ when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) - let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion+ 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 RSA signatureCreds- CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning DSS signatureCreds- CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds+ 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", True, HandshakeFailure) resumeSessionData <- case clientSession of@@ -215,15 +267,9 @@ in validateSession serverName <$> resume (Session Nothing) -> return Nothing - maybe (return ()) (usingState_ ctx . setClientSNI) serverName-- case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of- Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos- _ -> return ()- -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed.- case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of+ case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode MsgTClientHello of Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () @@ -246,9 +292,6 @@ | isJust sni && sessionClientSNI sd /= sni = Nothing | otherwise = m --handshakeServerWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeServerWith", True, HandshakeFailure)- doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher -> Compression -> Session -> Maybe SessionData -> [ExtensionRaw] -> IO ()@@ -264,36 +307,23 @@ usingState_ ctx (setSession clientSession True) serverhello <- makeServerHello clientSession sendPacket ctx $ Handshake [serverhello]- usingHState ctx $ setMasterSecret chosenVersion ServerRole $ sessionSecret sessionData+ let masterSecret = sessionSecret sessionData+ usingHState ctx $ setMasterSecret chosenVersion ServerRole masterSecret+ logKey ctx (MasterSecret masterSecret) sendChangeCipherAndFinish ctx ServerRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where- clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts-- applicationProtocol | clientALPNSuggest = do- suggest <- usingState_ ctx getClientALPNSuggest- case (onALPNClientSuggest $ serverHooks sparams, suggest) of- (Just io, Just protos) -> do- proto <- liftIO $ io protos- usingState_ ctx $ do- setExtensionALPN True- setNegotiatedProtocol proto- return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation- (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]- (_, _) -> return []- | otherwise = return []- --- -- When the client sends a certificate, check whether -- it is acceptable for the application. -- --- makeServerHello session = do- srand <- ServerRandom <$> getStateRNG ctx 32+ srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams case mcred of- Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey- _ -> return () -- return a sensible error+ 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.@@ -306,7 +336,8 @@ return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ ExtensionRaw extensionID_SecureRenegotiation vf ] else return []- protoExt <- applicationProtocol++ protoExt <- applicationProtocol ctx exts sparams sniExt <- do resuming <- usingState_ ctx isSessionResuming if resuming@@ -339,24 +370,31 @@ -- send server key exchange if needed skx <- case cipherKeyExchange usedCipher of CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon- CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE RSA- CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE DSS- CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE RSA+ 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 confgure CA- -- certificates.+ -- 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 certTypes = [ CertificateType_RSA_Sign ]- hashSigs = if usedVersion < TLS12- then Nothing- else Just (supportedHashSignatures $ ctxSupported ctx)+ 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@@ -375,11 +413,15 @@ [] -> let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams in case findFiniteFieldGroup dhparams of- Just g -> generateFFDHE ctx g+ Just g -> do+ usingHState ctx $ setNegotiatedGroup g+ generateFFDHE ctx g Nothing -> do (priv, pub) <- generateDHE ctx dhparams return (dhparams, priv, pub)- g:_ -> generateFFDHE ctx g+ g:_ -> do+ usingHState ctx $ setNegotiatedGroup g+ generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub @@ -403,35 +445,39 @@ x:_ -> return $ Just x _ -> return Nothing - generateSKX_DHE sigAlg = do+ generateSKX_DHE kxsAlg = do serverParams <- setup_DHE+ sigAlg <- getLocalDigitalSignatureAlg ctx mhashSig <- decideHashSig sigAlg signed <- digitallySignDHParams ctx serverParams sigAlg mhashSig- case sigAlg of- RSA -> return $ SKX_DHE_RSA serverParams signed- DSS -> return $ SKX_DHE_DSS serverParams signed- _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg)+ 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 $ setECDHPrivate srvpri+ usingHState ctx $ setGroupPrivate srvpri return serverParams - generateSKX_ECDHE sigAlg = do+ generateSKX_ECDHE kxsAlg = do let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp+ sigAlg <- getLocalDigitalSignatureAlg ctx mhashSig <- decideHashSig sigAlg signed <- digitallySignECDHParams ctx serverParams sigAlg mhashSig- case sigAlg of- RSA -> return $ SKX_ECDHE_RSA serverParams signed- _ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg)+ 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. @@ -446,19 +492,7 @@ recvClientData :: ServerParams -> Context -> IO () recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) where processClientCertificate (Certificates certs) = do- -- run certificate recv hook- ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs)- -- Call application callback to see whether the- -- certificate chain is acceptable.- --- usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException- case usage of- CertificateUsageAccept -> return ()- CertificateUsageReject reason -> certificateRejected reason-- -- Remember cert chain for later use.- --- usingHState ctx $ setClientCertChain certs+ clientCertificate sparams ctx certs -- FIXME: We should check whether the certificate -- matches our request and that we support@@ -479,7 +513,7 @@ processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do processHandshake ctx hs - checkValidClientCertChain "change cipher message expected"+ certs <- checkValidClientCertChain ctx "change cipher message expected" usedVersion <- usingState_ ctx getVersion -- Fetch all handshake messages up to now.@@ -487,32 +521,8 @@ sigAlgExpected <- getRemoteSignatureAlg - -- FIXME should check certificate is allowed for signing- verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig-- if verif then do- -- When verification succeeds, commit the- -- client certificate chain to the context.- --- Just certs <- usingHState ctx getClientCertChain- 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.- Just certs <- usingHState ctx getClientCertChain- usingState_ ctx $ setClientCertificateChain certs- else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)+ clientCertVerify sparams ctx certs verif return $ RecvStateNext expectChangeCipher processCertificateVerify p = do@@ -525,11 +535,9 @@ getRemoteSignatureAlg = do pk <- usingHState ctx getRemotePublicKey- case pk of- PubKeyRSA _ -> return RSA- PubKeyDSA _ -> return DSS- PubKeyEC _ -> return ECDSA- _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)+ case fromPubKey pk of+ Nothing -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)+ Just sig -> return sig expectChangeCipher ChangeCipherSpec = do return $ RecvStateHandshake expectFinish@@ -539,17 +547,18 @@ expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") - checkValidClientCertChain msg = do- chain <- usingHState ctx getClientCertChain- let throwerror = Error_Protocol (msg , True, UnexpectedMessage)- case chain of- Nothing -> throwCore throwerror- Just cc | isNullCertificateChain cc -> throwCore throwerror- | otherwise -> return ()+checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain+checkValidClientCertChain ctx errmsg = do+ chain <- usingHState ctx getClientCertChain+ let throwerror = Error_Protocol (errmsg , True, UnexpectedMessage)+ case chain of+ Nothing -> throwCore throwerror+ Just cc | isNullCertificateChain cc -> throwCore throwerror+ | otherwise -> return cc hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] hashAndSignaturesInCommon ctx exts =- let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False 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)@@ -563,7 +572,7 @@ in sHashSigs `intersect` cHashSigs negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]-negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of+negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of Just (NegotiatedGroups clientGroups) -> let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups@@ -578,27 +587,385 @@ let orderedPairs = sortOn fst [ (rankFun cred, cred) | cred <- creds ] in Credentials [ cred | (Just _, cred) <- orderedPairs ] +-- Filters a list of candidate credentials with credentialMatchesHashSignatures.+--+-- Algorithms to filter with are taken from "signature_algorithms_cert"+-- extension when it exists, else from "signature_algorithms" when clients do+-- not implement the new extension (see RFC 8446 section 4.2.3).+--+-- Resulting credential list can be used as input to the hybrid cipher-and-+-- certificate selection for TLS12, or to the direct certificate selection+-- simplified with TLS13. As filtering credential signatures with client-+-- advertised algorithms is not supposed to cause negotiation failure, in case+-- of dead end with the subsequent selection process, this process should always+-- be restarted with the unfiltered credential list as input (see fallback+-- certificate chains, described in same RFC section).+--+-- Calling code should not forget to apply constraints of extension+-- "signature_algorithms" to any signature-based key exchange derived from the+-- output credentials. Respecting client constraints on KX signatures is+-- mandatory but not implemented by this function. filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials filterCredentialsWithHashSignatures exts =- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of- Nothing -> id- Just (SignatureAlgorithms sas) ->- let filterCredentials p (Credentials l) = Credentials (filter p l)- in filterCredentials (credentialMatchesHashSignatures sas)+ case withExt extensionID_SignatureAlgorithmsCert of+ Just (SignatureAlgorithmsCert sas) -> withAlgs sas+ Nothing ->+ case withExt extensionID_SignatureAlgorithms of+ Nothing -> id+ Just (SignatureAlgorithms sas) -> withAlgs sas+ where+ withExt extId = extensionLookup extId exts >>= extensionDecode MsgTClientHello+ withAlgs sas = filterCredentials (credentialMatchesHashSignatures sas)+ filterCredentials p (Credentials l) = Credentials (filter p l) --- returns True if "signature_algorithms" certificate filtering produced no--- ephemeral D-H nor TLS13 cipher (so handshake with lower security)+-- returns True if certificate filtering with "signature_algorithms_cert" /+-- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so+-- handshake with lower security) cipherListCredentialFallback :: [Cipher] -> Bool-cipherListCredentialFallback xs = all nonDH xs+cipherListCredentialFallback = all nonDH where nonDH x = case cipherKeyExchange x of CipherKeyExchange_DHE_RSA -> False CipherKeyExchange_DHE_DSS -> False CipherKeyExchange_ECDHE_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False- --CipherKeyExchange_TLS13 -> False+ 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+ -> Credentials+ -> [ExtensionRaw]+ -> [CipherID]+ -> Maybe String+ -> Session+ -> IO ()+handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts clientCiphers _serverName clientSession = do+ -- 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", True, HandshakeFailure)+ let usedCipher = onCipherChoosing (serverHooks sparams) chosenVersion ciphersFilteredVersion+ usedHash = cipherHash usedCipher+ rtt0 = case extensionLookup extensionID_EarlyData exts >>= extensionDecode MsgTClientHello of+ Just (EarlyDataIndication _) -> True+ Nothing -> False+ when rtt0 $+ -- mark a 0-RTT attempt before a possible HRR, and before updating the+ -- status again if 0-RTT successful+ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ -- Deciding key exchange from key shares+ keyShares <- case extensionLookup extensionID_KeyShare exts >>= extensionDecode MsgTClientHello of+ Just (KeyShareClientHello kses) -> return kses+ Just _ -> error "handshakeServerWithTLS13: invalid KeyShare value"+ _ -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure)+ case findKeyShare keyShares serverGroups of+ Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession+ Just keyShare -> doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash keyShare clientSession rtt0+ where+ ciphersFilteredVersion = filter ((`elem` clientCiphers) . cipherID) serverCiphers+ serverCiphers = filter (cipherAllowedForVersion chosenVersion) (supportedCiphers $ serverSupported sparams)+ serverGroups = supportedGroups (ctxSupported ctx)+ findKeyShare _ [] = Nothing+ findKeyShare ks (g:gs) = case find (\ent -> keyShareEntryGroup ent == g) ks of+ Just k -> Just k+ Nothing -> findKeyShare ks gs++doHandshake13 :: ServerParams -> Context -> Credentials -> Version+ -> Cipher -> [ExtensionRaw]+ -> Hash -> KeyShareEntry+ -> Session -> Bool+ -> IO ()+doHandshake13 sparams ctx allCreds chosenVersion usedCipher exts usedHash clientKeyShare clientSession rtt0 = do+ newSession ctx >>= \ss -> usingState_ ctx (setSession ss False)+ usingHState ctx $ setNegotiatedGroup $ keyShareEntryGroup clientKeyShare+ srand <- setServerParameter+ (psk, binderInfo, is0RTTvalid) <- choosePSK+ hCh <- transcriptHash ctx+ let earlySecret = hkdfExtract usedHash zero psk+ clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh+ logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)+ extensions <- checkBinder earlySecret binderInfo+ hrr <- usingState_ ctx getTLS13HRR+ let authenticated = isJust binderInfo+ rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+ ----------------------------------------------------------------+ 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+ (ecdhe,keyShare) <- makeServerKeyShare ctx clientKeyShare+ let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe+ clientHandshakeTrafficSecret <- runPacketFlight ctx $ do+ sendServerHello keyShare srand extensions+ ----------------------------------------------------------------+ hChSh <- transcriptHash ctx+ let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh+ serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh+ liftIO $ do+ logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret)+ logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret)+ setRxState ctx usedHash usedCipher $ if rtt0OK then clientEarlyTrafficSecret else clientHandshakeTrafficSecret+ setTxState ctx usedHash usedCipher serverHandshakeTrafficSecret+ ----------------------------------------------------------------+ loadPacket13 ctx ChangeCipherSpec13+ sendExtensions rtt0OK+ case mCredInfo of+ Nothing -> return ()+ Just (cred, hashSig) -> sendCertAndVerify cred hashSig+ rawFinished <- makeFinished ctx usedHash serverHandshakeTrafficSecret+ loadPacket13 ctx $ Handshake13 [rawFinished]+ return clientHandshakeTrafficSecret+ sfSentTime <- getCurrentTimeFromBase+ ----------------------------------------------------------------+ let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero+ hChSf <- transcriptHash ctx+ let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf+ serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf+ exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf+ usingState_ ctx $ setExporterMasterSecret exporterMasterSecret+ ----------------------------------------------------------------+ logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0)+ logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0)+ setTxState ctx usedHash usedCipher serverApplicationTrafficSecret0+ ----------------------------------------------------------------+ if rtt0OK then+ setEstablished ctx (EarlyDataAllowed rtt0max)+ else when (established == NotEstablished) $+ setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding++ let expectFinished (Finished13 verifyData') = do+ hChBeforeCf <- transcriptHash ctx+ let verifyData = makeVerifyData usedHash clientHandshakeTrafficSecret hChBeforeCf+ if verifyData == verifyData' then liftIO $ do+ setEstablished ctx Established+ setRxState ctx usedHash usedCipher clientApplicationTrafficSecret0+ else+ decryptError "cannot verify finished"+ expectFinished hs = unexpected (show hs) (Just "finished 13")++ let expectEndOfEarlyData EndOfEarlyData13 =+ setRxState ctx usedHash usedCipher clientHandshakeTrafficSecret+ expectEndOfEarlyData hs = unexpected (show hs) (Just "end of early data")+ let sendNST = sendNewSessionTicket masterSecret sfSentTime++ if not authenticated && serverWantClientCert sparams then+ runRecvHandshake13 $ do+ skip <- recvHandshake13postUpdate ctx expectCertificate+ unless skip $ recvHandshake13postUpdate ctx expectCertVerify+ recvHandshake13postUpdate ctx expectFinished+ liftIO sendNST+ else if rtt0OK then+ setPendingActions ctx [(expectEndOfEarlyData, return ())+ ,(expectFinished, sendNST)]+ else do+ setPendingActions ctx [(expectFinished, sendNST)]+ where+ setServerParameter = do+ srand <- serverRandom ctx chosenVersion $ supportedVersions $ serverSupported sparams+ usingState_ ctx $ setVersion chosenVersion+ usingHState ctx $ setHelloParameters13 usedCipher+ return srand++ choosePSK = case extensionLookup extensionID_PreSharedKey exts >>= extensionDecode MsgTClientHello of+ Just (PreSharedKeyClientHello (PskIdentity sessionId obfAge:_) bnds@(bnd:_)) -> 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)+ _ -> return (zero, Nothing, False)++ checkSessionEquality sdata = do+ msni <- usingState_ ctx getClientSNI+ malpn <- usingState_ ctx getNegotiatedProtocol+ let isSameSNI = sessionClientSNI sdata == msni+ isSameCipher = sessionCipher sdata == cipherID usedCipher+ ciphers = supportedCiphers $ serverSupported sparams+ isSameKDF = case find (\c -> cipherID c == sessionCipher sdata) ciphers of+ Nothing -> False+ Just c -> cipherHash c == cipherHash usedCipher+ isSameVersion = chosenVersion == sessionVersion sdata+ isSameALPN = sessionALPN sdata == malpn+ isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required+ is0RTTvalid = isSameVersion && isSameCipher && isSameALPN+ return (isPSKvalid, is0RTTvalid)++ rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams+ rtt0accept = serverEarlyDataSize sparams > 0++ checkBinder _ Nothing = return []+ checkBinder earlySecret (Just (binder,n,tlen)) = do+ binder' <- makePSKBinder ctx earlySecret usedHash tlen Nothing+ unless (binder `bytesEq` binder') $+ decryptError "PSK binder validation failed"+ let selectedIdentity = extensionEncode $ PreSharedKeyServerHello $ fromIntegral n+ return [ExtensionRaw extensionID_PreSharedKey selectedIdentity]++ decideCredentialInfo = do+ cHashSigs <- case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode MsgTClientHello of+ Nothing -> throwCore $ Error_Protocol ("no signature_algorithms extension", True, MissingExtension)+ Just (SignatureAlgorithms sas) -> return sas+ -- When deciding signature algorithm and certificate, we try to keep+ -- certificates supported by the client, but fallback to all credentials+ -- if this produces no suitable result (see RFC 5246 section 7.4.2 and+ -- RFC 8446 section 4.4.2.2).+ let sHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx+ hashSigs = sHashSigs `intersect` cHashSigs+ cltCreds = filterCredentialsWithHashSignatures exts allCreds+ case credentialsFindForSigning13 hashSigs cltCreds of+ Nothing ->+ case credentialsFindForSigning13 hashSigs allCreds of+ Nothing -> throwCore $ Error_Protocol ("credential not found", True, HandshakeFailure)+ mcs -> return mcs+ mcs -> return mcs++ sendServerHello keyShare srand extensions = do+ let serverKeyShare = extensionEncode $ KeyShareServerHello keyShare+ selectedVersion = extensionEncode $ SupportedVersionsServerHello chosenVersion+ extensions' = ExtensionRaw extensionID_KeyShare serverKeyShare+ : ExtensionRaw extensionID_SupportedVersions selectedVersion+ : extensions+ helo = ServerHello13 srand clientSession (cipherID usedCipher) extensions'+ loadPacket13 ctx $ Handshake13 [helo]++ sendCertAndVerify cred@(certChain, _) hashSig = do+ storePrivInfoServer ctx cred+ when (serverWantClientCert sparams) $ do+ let certReqCtx = "" -- this must be zero length here.+ let sigAlgs = extensionEncode $ SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx+ crexts = [ExtensionRaw extensionID_SignatureAlgorithms sigAlgs]+ loadPacket13 ctx $ Handshake13 [CertRequest13 certReqCtx crexts]+ usingHState ctx $ setCertReqSent True++ let CertificateChain cs = certChain+ ess = replicate (length cs) []+ loadPacket13 ctx $ Handshake13 [Certificate13 "" certChain ess]+ hChSc <- transcriptHash ctx+ sigAlg <- getLocalDigitalSignatureAlg ctx+ vrfy <- makeCertVerify ctx sigAlg hashSig hChSc+ loadPacket13 ctx $ Handshake13 [vrfy]++ sendExtensions rtt0OK = do+ extensions' <- liftIO $ applicationProtocol ctx exts sparams+ msni <- liftIO $ usingState_ ctx getClientSNI+ let extensions'' = 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 _ -> ExtensionRaw extensionID_ServerName "" : extensions'+ Nothing -> extensions'+ let extensions+ | rtt0OK = ExtensionRaw extensionID_EarlyData (extensionEncode (EarlyDataIndication Nothing)) : extensions''+ | otherwise = extensions''+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions]++ sendNewSessionTicket masterSecret sfSentTime = when sendNST $ do+ cfRecvTime <- getCurrentTimeFromBase+ let rtt = cfRecvTime - sfSentTime+ hChCf <- transcriptHash ctx+ nonce <- getStateRNG ctx 32+ let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf+ life = 86400 -- 1 day in second: fixme hard coding+ psk = hkdfExpandLabel usedHash resumptionMasterSecret "resumption" nonce hashSize+ (label, add) <- generateSession life psk rtt0max rtt+ let nst = createNewSessionTicket life add nonce label rtt0max+ sendPacket13 ctx $ Handshake13 [nst]+ where+ sendNST = (PSK_KE `elem` dhModes) || (PSK_DHE_KE `elem` dhModes)+ dhModes = case extensionLookup extensionID_PskKeyExchangeModes exts >>= extensionDecode MsgTClientHello of+ Just (PskKeyExchangeModes ms) -> ms+ Nothing -> []+ generateSession life psk maxSize rtt = do+ Session (Just sessionId) <- newSession ctx+ tinfo <- createTLS13TicketInfo life (Left ctx) (Just rtt)+ sdata <- getSessionData13 ctx usedCipher tinfo maxSize psk+ let mgr = sharedSessionManager $ serverShared sparams+ sessionEstablish mgr sessionId sdata+ return (sessionId, ageAdd tinfo)+ createNewSessionTicket life add nonce label maxSize =+ NewSessionTicket13 life add nonce label extensions+ where+ tedi = extensionEncode $ EarlyDataIndication $ Just $ fromIntegral maxSize+ extensions = [ExtensionRaw extensionID_EarlyData tedi]++ expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool+ expectCertificate (Certificate13 certCtx certs _ext) = liftIO $ do+ when (certCtx /= "") $ throwCore $ Error_Protocol ("certificate request context MUST be empty", True, IllegalParameter)+ -- fixme checking _ext+ clientCertificate sparams ctx certs+ return $ isNullCertificateChain certs+ expectCertificate hs = unexpected (show hs) (Just "certificate 13")++ expectCertVerify :: Handshake13 -> RecvHandshake13M IO ()+ expectCertVerify (CertVerify13 sigAlg sig) = liftIO $ do+ hChCc <- transcriptHash ctx+ certs@(CertificateChain cc) <- checkValidClientCertChain ctx "finished 13 message expected"+ pubkey <- case cc of+ [] -> throwCore $ Error_Protocol ("client certificate missing", True, HandshakeFailure)+ c:_ -> return $ certPubKey $ getCertificate c+ usingHState ctx $ setPublicKey pubkey+ let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)+ verif <- checkCertVerify ctx keyAlg sigAlg sig hChCc+ clientCertVerify sparams ctx certs verif+ expectCertVerify hs = unexpected (show hs) (Just "certificate verify 13")++ hashSize = hashDigestSize usedHash+ zero = B.replicate hashSize 0++helloRetryRequest :: MonadIO m => ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> m ()+helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession = liftIO $ do+ twice <- usingState_ ctx getTLS13HRR+ when twice $+ throwCore $ Error_Protocol ("Hello retry not allowed again", True, HandshakeFailure)+ usingState_ ctx $ setTLS13HRR True+ usingHState ctx $ setHelloParameters13 usedCipher+ let clientGroups = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode MsgTClientHello of+ Just (NegotiatedGroups gs) -> gs+ Nothing -> []+ possibleGroups = serverGroups `intersect` clientGroups+ case possibleGroups of+ [] -> throwCore $ Error_Protocol ("no group in common with the client for HRR", True, 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+ sendPacket13 ctx $ Handshake13 [hrr]+ handshakeServer sparams ctx+ findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions = case filter (clientVersion >=) $ sortOn Down allowedVersions of@@ -620,8 +987,7 @@ CipherKeyExchange_DHE_RSA -> canSignRSA CipherKeyExchange_DHE_DSS -> canSignDSS CipherKeyExchange_ECDHE_RSA -> canSignRSA- -- unimplemented: EC- CipherKeyExchange_ECDHE_ECDSA -> False+ 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@@ -630,8 +996,90 @@ CipherKeyExchange_DH_RSA -> False CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False+ CipherKeyExchange_TLS13 -> False -- not reached - canSignDSS = DSS `elem` signingAlgs- canSignRSA = RSA `elem` signingAlgs+ canSignDSS = KX_DSS `elem` signingAlgs+ canSignRSA = KX_RSA `elem` signingAlgs+ canSignECDSA = KX_ECDSA `elem` signingAlgs canEncryptRSA = isJust $ credentialsFindForDecrypting creds signingAlgs = credentialsListSigningAlgorithms sigCreds++findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version+findHighestVersionFrom13 clientVersions serverVersions = case svs `intersect` cvs of+ [] -> Nothing+ v:_ -> Just v+ where+ svs = sortOn Down serverVersions+ cvs = sortOn Down clientVersions++applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]+applicationProtocol ctx exts sparams+ | clientALPNSuggest = do+ suggest <- usingState_ ctx getClientALPNSuggest+ case (onALPNClientSuggest $ serverHooks sparams, suggest) of+ (Just io, Just protos) -> do+ proto <- io protos+ usingState_ ctx $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation+ (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]+ (_, _) -> return []+ | otherwise = return []+ where+ clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts++credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)+credentialsFindForSigning13 hss0 creds = loop hss0+ where+ loop [] = Nothing+ loop (hs:hss) = case credentialsFindForSigning13' hs creds of+ Nothing -> credentialsFindForSigning13 hss creds+ Just cred -> Just (cred, hs)++-- See credentialsFindForSigning.+credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential+credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l+ where+ forSigning cred = case credentialDigitalSignatureAlg cred of+ Nothing -> False+ Just sig -> sig `signatureCompatible` sigAlg++clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()+clientCertificate sparams ctx certs = do+ -- run certificate recv hook+ ctxWithHooks ctx (`hookRecvCertificates` certs)+ -- Call application callback to see whether the+ -- certificate chain is acceptable.+ --+ usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException+ case usage of+ CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ CertificateUsageReject reason -> certificateRejected reason++ -- Remember cert chain for later use.+ --+ usingHState ctx $ setClientCertChain certs++clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()+clientCertVerify sparams ctx certs verif = do+ if verif then do+ -- When verification succeeds, commit the+ -- client certificate chain to the context.+ --+ usingState_ ctx $ setClientCertificateChain certs+ return ()+ else do+ -- Either verification failed because of an+ -- invalid format (with an error message), or+ -- the signature is wrong. In either case,+ -- ask the application if it wants to+ -- proceed, we will do that.+ res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)+ if res then do+ -- When verification fails, but the+ -- application callbacks accepts, we+ -- also commit the client certificate+ -- chain to the context.+ usingState_ ctx $ setClientCertificateChain certs+ else decryptError "verification failed"
Network/TLS/Handshake/Signature.hs view
@@ -14,11 +14,18 @@ , digitallySignECDHParams , digitallySignDHParamsVerify , digitallySignECDHParamsVerify+ , checkSupportedHashSignature+ , certificateCompatible , signatureCompatible+ , hashSigToCertType+ , signatureParams+ , fromPubKey+ , decryptError ) where import Network.TLS.Crypto import Network.TLS.Context.Internal+import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Imports import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS,@@ -30,15 +37,78 @@ import Control.Monad.State.Strict +fromPubKey :: PubKey -> Maybe DigitalSignatureAlg+fromPubKey (PubKeyRSA _) = Just DS_RSA+fromPubKey (PubKeyDSA _) = Just DS_DSS+fromPubKey (PubKeyEC _) = Just DS_ECDSA+fromPubKey (PubKeyEd25519 _) = Just DS_Ed25519+fromPubKey (PubKeyEd448 _) = Just DS_Ed448+fromPubKey _ = Nothing++decryptError :: MonadIO m => String -> m a+decryptError msg = throwCore $ Error_Protocol (msg, True, DecryptError)++-- | Check that the signature algorithm is compatible with a list of+-- 'CertificateType' values. Ed25519 and Ed448 have no assigned code point+-- and are checked with extension "signature_algorithms" only.+certificateCompatible :: DigitalSignatureAlg -> [CertificateType] -> Bool+certificateCompatible DS_RSA cTypes = CertificateType_RSA_Sign `elem` cTypes+certificateCompatible DS_DSS cTypes = CertificateType_DSS_Sign `elem` cTypes+certificateCompatible DS_ECDSA cTypes = CertificateType_ECDSA_Sign `elem` cTypes+certificateCompatible DS_Ed25519 _ = True+certificateCompatible DS_Ed448 _ = True+ signatureCompatible :: DigitalSignatureAlg -> HashAndSignatureAlgorithm -> Bool-signatureCompatible RSA (_, SignatureRSA) = True-signatureCompatible RSA (_, SignatureRSApssSHA256) = True-signatureCompatible RSA (_, SignatureRSApssSHA384) = True-signatureCompatible RSA (_, SignatureRSApssSHA512) = True-signatureCompatible DSS (_, SignatureDSS) = True-signatureCompatible ECDSA (_, SignatureECDSA) = True-signatureCompatible _ (_, _) = False+signatureCompatible DS_RSA (_, SignatureRSA) = True+signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA256) = True+signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA384) = True+signatureCompatible DS_RSA (_, SignatureRSApssRSAeSHA512) = True+signatureCompatible DS_DSS (_, SignatureDSS) = True+signatureCompatible DS_ECDSA (_, SignatureECDSA) = True+signatureCompatible DS_Ed25519 (_, SignatureEd25519) = True+signatureCompatible DS_Ed448 (_, SignatureEd448) = True+signatureCompatible _ (_, _) = False +-- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'.+-- Perhaps this needs to take supported groups into account, so that, for+-- example, if we don't support any shared ECDSA groups with the server, we+-- return 'Nothing' rather than 'CertificateType_ECDSA_Sign'.+--+-- Therefore, this interface is preliminary. It gets us moving in the right+-- direction. The interplay between all the various TLS extensions and+-- certificate selection is rather complex.+--+-- The goal is to ensure that the client certificate request callback only sees+-- 'CertificateType' values that are supported by the library and also+-- compatible with the server signature algorithms extension.+--+-- Since we don't yet support ECDSA private keys, the caller will use+-- 'lastSupportedCertificateType' to filter those out for now, leaving just+-- @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 (_, 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 _ = Nothing+ checkCertificateVerify :: Context -> Version -> DigitalSignatureAlg@@ -85,9 +155,9 @@ | usedVersion == SSL3 = do (hashCtx, params, generateCV_SSL) <- case sigAlg of- RSA -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL)- DSS -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS)- _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg)+ DS_RSA -> return (hashInit SHA1_MD5, RSAParams SHA1_MD5 RSApkcs1, generateCertificateVerify_SSL)+ DS_DSS -> return (hashInit SHA1, DSSParams, generateCertificateVerify_SSL_DSS)+ _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) Just masterSecret <- usingHState ctx $ gets hstMasterSecret return (params, generateCV_SSL masterSecret $ hashUpdate hashCtx msgs) | usedVersion == TLS10 || usedVersion == TLS11 =@@ -95,25 +165,25 @@ | otherwise = return (signatureParams sigAlg hashSigAlg, msgs) signatureParams :: DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> SignatureParams-signatureParams RSA hashSigAlg =+signatureParams DS_RSA 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 , SignatureRSApssSHA512) -> RSAParams SHA512 RSApss- Just (HashIntrinsic , SignatureRSApssSHA384) -> RSAParams SHA384 RSApss- Just (HashIntrinsic , SignatureRSApssSHA256) -> RSAParams SHA256 RSApss+ 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 DSS hashSigAlg =+signatureParams DS_DSS hashSigAlg = case hashSigAlg of Nothing -> DSSParams Just (HashSHA1, SignatureDSS) -> DSSParams Just (_ , SignatureDSS) -> error "invalid DSA hash choice, only SHA1 allowed" Just (_ , sigAlg) -> error ("signature algorithm is incompatible with DSS: " ++ show sigAlg)-signatureParams ECDSA hashSigAlg =+signatureParams DS_ECDSA hashSigAlg = case hashSigAlg of Just (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 Just (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384@@ -122,7 +192,18 @@ 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 sig _ = error ("unimplemented signature type: " ++ show sig)+signatureParams DS_Ed25519 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)+signatureParams DS_Ed448 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) signatureCreateWithCertVerifyData :: Context -> Maybe HashAndSignatureAlgorithm@@ -148,9 +229,9 @@ -> DigitallySigned -> CertVerifyData -> IO Bool-signatureVerifyWithCertVerifyData ctx (DigitallySigned _ bs) (sigParam, toVerify) = do- cc <- usingState_ ctx isClientContext- verifyPublic ctx cc sigParam toVerify bs+signatureVerifyWithCertVerifyData ctx (DigitallySigned hs bs) (sigParam, toVerify) = do+ checkSupportedHashSignature ctx hs+ verifyPublic ctx sigParam toVerify bs digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned digitallySignParams ctx signatureData sigAlg hashSigAlg =@@ -198,3 +279,12 @@ (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 ctx (Just hs) =+ unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $+ let msg = "unsupported hash and signature algorithm: " ++ show hs+ in throwCore $ Error_Protocol (msg, True, IllegalParameter)
Network/TLS/Handshake/State.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-}@@ -10,14 +11,18 @@ -- module Network.TLS.Handshake.State ( HandshakeState(..)- , ClientCertRequestData+ , HandshakeDigest(..)+ , HandshakeMode13(..)+ , RTT0Status(..)+ , Secret13(..)+ , CertReqCBdata , HandshakeM , newEmptyHandshake , runHandshake -- * key accessors , setPublicKey- , setPrivateKey- , getLocalPrivateKey+ , setPublicPrivateKeys+ , getLocalPublicPrivateKeys , getRemotePublicKey , setServerDHParams , getServerDHParams@@ -25,8 +30,8 @@ , getServerECDHParams , setDHPrivate , getDHPrivate- , setECDHPrivate- , getECDHPrivate+ , setGroupPrivate+ , getGroupPrivate -- * cert accessors , setClientCertSent , getClientCertSent@@ -34,19 +39,33 @@ , getCertReqSent , setClientCertChain , getClientCertChain- , setClientCertRequest- , getClientCertRequest+ , setCertReqToken+ , getCertReqToken+ , setCertReqCBdata+ , getCertReqCBdata+ , setCertReqSigAlgsCert+ , getCertReqSigAlgsCert -- * digest accessors , addHandshakeMessage , updateHandshakeDigest , getHandshakeMessages+ , getHandshakeMessagesRev , getHandshakeDigest+ , foldHandshakeDigest -- * master secret , setMasterSecret , setMasterSecretFromPre -- * misc accessor , getPendingCipher , setServerHelloParameters+ , setNegotiatedGroup+ , getNegotiatedGroup+ , setTLS13HandshakeMode+ , getTLS13HandshakeMode+ , setTLS13RTT0Status+ , getTLS13RTT0Status+ , setTLS13Secret+ , getTLS13Secret ) where import Network.TLS.Util@@ -62,11 +81,20 @@ import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess) +data Secret13 = NoSecret+ | EarlySecret ByteString+ | ResuptionSecret ByteString+ deriving (Eq, Show)+ data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey)- , hksLocalPrivateKey :: !(Maybe PrivKey)+ , hksLocalPublicPrivateKeys :: !(Maybe (PubKey, PrivKey)) } deriving (Show) +data HandshakeDigest = HandshakeMessages [ByteString]+ | HandshakeDigestContext HashCtx+ deriving (Show)+ data HandshakeState = HandshakeState { hstClientVersion :: !Version , hstClientRandom :: !ClientRandom@@ -76,23 +104,81 @@ , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate) , hstServerECDHParams :: !(Maybe ServerECDHParams)- , hstECDHPrivate :: !(Maybe GroupPrivate)- , hstHandshakeDigest :: !(Either [ByteString] HashCtx)+ , hstGroupPrivate :: !(Maybe GroupPrivate)+ , hstHandshakeDigest :: !HandshakeDigest , hstHandshakeMessages :: [ByteString]- , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received- , hstClientCertSent :: !Bool -- ^ Set to true when a client certificate chain was sent- , hstCertReqSent :: !Bool -- ^ Set to true when a certificate request was sent+ , 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 , hstClientCertChain :: !(Maybe CertificateChain) , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression+ , hstNegotiatedGroup :: Maybe Group+ , hstTLS13HandshakeMode :: HandshakeMode13+ , hstTLS13RTT0Status :: !RTT0Status+ , hstTLS13Secret :: Secret13 } deriving (Show) -type ClientCertRequestData = ([CertificateType],- Maybe [(HashAlgorithm, SignatureAlgorithm)],- [DistinguishedName])+{- | 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+ <https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-parameters-2+ TLS ClientCertificateType Identifiers> 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] )+ newtype HandshakeM a = HandshakeM { runHandshakeM :: State HandshakeState a } deriving (Functor, Applicative, Monad) @@ -114,10 +200,12 @@ , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing- , hstECDHPrivate = Nothing- , hstHandshakeDigest = Left []+ , hstGroupPrivate = Nothing+ , hstHandshakeDigest = HandshakeMessages [] , hstHandshakeMessages = []- , hstClientCertRequest = Nothing+ , hstCertReqToken = Nothing+ , hstCertReqCBdata = Nothing+ , hstCertReqSigAlgsCert = Nothing , hstClientCertSent = False , hstCertReqSent = False , hstClientCertChain = Nothing@@ -125,6 +213,10 @@ , hstPendingRxState = Nothing , hstPendingCipher = Nothing , hstPendingCompression = nullCompression+ , hstNegotiatedGroup = Nothing+ , hstTLS13HandshakeMode = FullHandshake+ , hstTLS13RTT0Status = RTT0None+ , hstTLS13Secret = NoSecret } runHandshake :: HandshakeState -> HandshakeM a -> (a, HandshakeState)@@ -134,40 +226,82 @@ setPublicKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) }) where setPK hks = hks { hksRemotePublicKey = Just pk } -setPrivateKey :: PrivKey -> HandshakeM ()-setPrivateKey pk = modify (\hst -> hst { hstKeyState = setPK (hstKeyState hst) })- where setPK hks = hks { hksLocalPrivateKey = Just pk }+setPublicPrivateKeys :: (PubKey, PrivKey) -> HandshakeM ()+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) -getLocalPrivateKey :: HandshakeM PrivKey-getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState)+getLocalPublicPrivateKeys :: HandshakeM (PubKey, PrivKey)+getLocalPublicPrivateKeys = fromJust "local public/private key" <$> gets (hksLocalPublicPrivateKeys . hstKeyState) +setServerDHParams :: ServerDHParams -> HandshakeM ()+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 })+ getServerECDHParams :: HandshakeM ServerECDHParams getServerECDHParams = fromJust "server ECDH params" <$> gets hstServerECDHParams -setServerDHParams :: ServerDHParams -> HandshakeM ()-setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp })--setServerECDHParams :: ServerECDHParams -> HandshakeM ()-setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp })+setDHPrivate :: DHPrivate -> HandshakeM ()+setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp }) getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate -getECDHPrivate :: HandshakeM GroupPrivate-getECDHPrivate = fromJust "server ECDH private" <$> gets hstECDHPrivate+getGroupPrivate :: HandshakeM GroupPrivate+getGroupPrivate = fromJust "server ECDH private" <$> gets hstGroupPrivate -setDHPrivate :: DHPrivate -> HandshakeM ()-setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp })+setGroupPrivate :: GroupPrivate -> HandshakeM ()+setGroupPrivate shp = modify (\hst -> hst { hstGroupPrivate = Just shp }) -setECDHPrivate :: GroupPrivate -> HandshakeM ()-setECDHPrivate shp = modify (\hst -> hst { hstECDHPrivate = Just shp })+setNegotiatedGroup :: Group -> HandshakeM ()+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.+ FullHandshake+ -- | Full handshake is used with hello retry reuest.+ | 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 })++getTLS13HandshakeMode :: HandshakeM HandshakeMode13+getTLS13HandshakeMode = gets hstTLS13HandshakeMode++data RTT0Status = RTT0None+ | RTT0Sent+ | RTT0Accepted+ | RTT0Rejected+ deriving (Show,Eq)++setTLS13RTT0Status :: RTT0Status -> HandshakeM ()+setTLS13RTT0Status s = modify (\hst -> hst { hstTLS13RTT0Status = s })++getTLS13RTT0Status :: HandshakeM RTT0Status+getTLS13RTT0Status = gets hstTLS13RTT0Status++setTLS13Secret :: Secret13 -> HandshakeM ()+setTLS13Secret secret = modify (\hst -> hst { hstTLS13Secret = secret })++getTLS13Secret :: HandshakeM Secret13+getTLS13Secret = gets hstTLS13Secret+ setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) @@ -186,12 +320,28 @@ getClientCertChain :: HandshakeM (Maybe CertificateChain) getClientCertChain = gets hstClientCertChain -setClientCertRequest :: ClientCertRequestData -> HandshakeM ()-setClientCertRequest d = modify (\hst -> hst { hstClientCertRequest = Just d })+--+setCertReqToken :: Maybe ByteString -> HandshakeM ()+setCertReqToken token = modify $ \hst -> hst { hstCertReqToken = token } -getClientCertRequest :: HandshakeM (Maybe ClientCertRequestData)-getClientCertRequest = gets hstClientCertRequest+getCertReqToken :: HandshakeM (Maybe ByteString)+getCertReqToken = gets hstCertReqToken +--+setCertReqCBdata :: Maybe CertReqCBdata -> HandshakeM ()+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 }++getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm])+getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert++-- getPendingCipher :: HandshakeM Cipher getPendingCipher = fromJust "pending cipher" <$> gets hstPendingCipher @@ -201,20 +351,42 @@ getHandshakeMessages :: HandshakeM [ByteString] getHandshakeMessages = gets (reverse . hstHandshakeMessages) +getHandshakeMessagesRev :: HandshakeM [ByteString]+getHandshakeMessagesRev = gets hstHandshakeMessages+ updateHandshakeDigest :: ByteString -> HandshakeM () updateHandshakeDigest content = modify $ \hs -> hs { hstHandshakeDigest = case hstHandshakeDigest hs of- Left bytes -> Left (content:bytes)- Right hashCtx -> Right $ hashUpdate hashCtx content }+ HandshakeMessages bytes -> HandshakeMessages (content:bytes)+ HandshakeDigestContext hashCtx -> HandshakeDigestContext $ hashUpdate hashCtx content } +-- | Compress the whole transcript with the specified function. Function @f@+-- takes the handshake digest as input and returns an encoded handshake message+-- to replace the transcript with.+foldHandshakeDigest :: Hash -> (ByteString -> ByteString) -> HandshakeM ()+foldHandshakeDigest hashAlg f = modify $ \hs ->+ case hstHandshakeDigest hs of+ HandshakeMessages bytes ->+ let hashCtx = foldl hashUpdate (hashInit hashAlg) $ reverse bytes+ !folded = f (hashFinal hashCtx)+ in hs { hstHandshakeDigest = HandshakeMessages [folded]+ , hstHandshakeMessages = [folded]+ }+ HandshakeDigestContext hashCtx ->+ let !folded = f (hashFinal hashCtx)+ hashCtx' = hashUpdate (hashInit hashAlg) folded+ in hs { hstHandshakeDigest = HandshakeDigestContext hashCtx'+ , hstHandshakeMessages = [folded]+ }+ getHandshakeDigest :: Version -> Role -> HandshakeM ByteString getHandshakeDigest ver role = gets gen where gen hst = case hstHandshakeDigest hst of- Right hashCtx ->+ HandshakeDigestContext hashCtx -> let msecret = fromJust "master secret" $ hstMasterSecret hst cipher = fromJust "cipher" $ hstPendingCipher hst in generateFinish ver cipher msecret hashCtx- Left _ ->+ HandshakeMessages _ -> error "un-initialized handshake digest" generateFinish | role == ClientRole = generateClientFinished | otherwise = generateServerFinished@@ -224,10 +396,11 @@ => Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side -> preMaster -- ^ the pre master secret- -> HandshakeM ()+ -> HandshakeM ByteString setMasterSecretFromPre ver role premasterSecret = do secret <- genSecret <$> get setMasterSecret ver role secret+ return secret where genSecret hst = generateMasterSecret ver (fromJust "cipher" $ hstPendingCipher hst) premasterSecret@@ -298,8 +471,8 @@ , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst } where hashAlg = getHash ver cipher- updateDigest (Left bytes) = Right $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes- updateDigest (Right _) = error "cannot initialize digest with another digest"+ 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.
+ Network/TLS/Handshake/State13.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.TLS.Handshake.State13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Handshake.State13+ ( getTxState+ , getRxState+ , setTxState+ , setRxState+ , clearTxState+ , clearRxState+ , setHelloParameters13+ , transcriptHash+ , wrapAsMessageHash13+ , setPendingActions+ , popPendingAction+ ) where++import Control.Concurrent.MVar+import Control.Monad.State+import qualified Data.ByteString as B+import Data.IORef+import Network.TLS.Cipher+import Network.TLS.Compression+import Network.TLS.Context.Internal+import Network.TLS.Crypto+import Network.TLS.Handshake.State+import Network.TLS.KeySchedule (hkdfExpandLabel)+import Network.TLS.Record.State+import Network.TLS.Imports+import Network.TLS.Util++getTxState :: Context -> IO (Hash, Cipher, ByteString)+getTxState ctx = getXState ctx ctxTxState++getRxState :: Context -> IO (Hash, Cipher, ByteString)+getRxState ctx = getXState ctx ctxRxState++getXState :: Context+ -> (Context -> MVar RecordState)+ -> IO (Hash, Cipher, ByteString)+getXState ctx func = do+ tx <- readMVar (func ctx)+ let Just usedCipher = stCipher tx+ usedHash = cipherHash usedCipher+ secret = cstMacSecret $ stCryptState tx+ return (usedHash, usedCipher, secret)++setTxState :: Context -> Hash -> Cipher -> ByteString -> IO ()+setTxState = setXState ctxTxState BulkEncrypt++setRxState :: Context -> Hash -> Cipher -> ByteString -> IO ()+setRxState = setXState ctxRxState BulkDecrypt++setXState :: (Context -> MVar RecordState) -> BulkDirection+ -> Context -> Hash -> Cipher -> ByteString+ -> IO ()+setXState func encOrDec ctx h cipher secret =+ modifyMVar_ (func ctx) (\_ -> return rt)+ where+ bulk = cipherBulk cipher+ keySize = bulkKeySize 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 }+ , stCipher = Just cipher+ , stCompression = nullCompression+ }++clearTxState :: Context -> IO ()+clearTxState = clearXState ctxTxState++clearRxState :: Context -> IO ()+clearRxState = clearXState ctxRxState++clearXState :: (Context -> MVar RecordState) -> Context -> IO ()+clearXState func ctx =+ modifyMVar_ (func ctx) (\rt -> return rt { stCipher = Nothing })++setHelloParameters13 :: Cipher -> HandshakeM ()+setHelloParameters13 cipher = modify update+ where+ update hst = case hstPendingCipher hst of+ Nothing -> hst {+ hstPendingCipher = Just cipher+ , hstPendingCompression = nullCompression+ , hstHandshakeDigest = updateDigest $ hstHandshakeDigest hst+ }+ Just oldcipher -> if cipher == oldcipher+ then hst+ else error "TLS 1.3: cipher changed"+ hashAlg = cipherHash cipher+ updateDigest (HandshakeMessages bytes) = HandshakeDigestContext $ foldl hashUpdate (hashInit hashAlg) $ reverse bytes+ updateDigest (HandshakeDigestContext _) = error "cannot initialize digest with another digest"++-- When a HelloRetryRequest is sent or received, the existing transcript must be+-- wrapped in a "message_hash" construct. See RFC 8446 section 4.4.1. This+-- applies to key-schedule computations as well as the ones for PSK binders.+wrapAsMessageHash13 :: HandshakeM ()+wrapAsMessageHash13 = do+ cipher <- getPendingCipher+ foldHandshakeDigest (cipherHash cipher) foldFunc+ where+ foldFunc dig = B.concat [ "\254\0\0"+ , B.singleton (fromIntegral $ B.length dig)+ , dig+ ]++transcriptHash :: MonadIO m => Context -> m ByteString+transcriptHash ctx = do+ hst <- fromJust "HState" <$> getHState ctx+ case hstHandshakeDigest hst of+ HandshakeDigestContext hashCtx -> return $ hashFinal hashCtx+ HandshakeMessages _ -> error "un-initialized handshake digest"++setPendingActions :: Context -> [PendingAction] -> IO ()+setPendingActions ctx = writeIORef (ctxPendingActions ctx)++popPendingAction :: Context -> IO (Maybe PendingAction)+popPendingAction ctx = do+ let ref = ctxPendingActions ctx+ actions <- readIORef ref+ case actions of+ bs:bss -> writeIORef ref bss >> return (Just bs)+ [] -> return Nothing
Network/TLS/IO.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Network.TLS.IO -- License : BSD-style@@ -9,28 +10,40 @@ module Network.TLS.IO ( checkValid , sendPacket+ , sendPacket13 , recvPacket+ , recvPacket13+ -- * Grouping multiple packets in the same flight+ , PacketFlightM+ , runPacketFlight+ , loadPacket13 ) where import Network.TLS.Context.Internal import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.Record+import Network.TLS.Record.Types13+import Network.TLS.Record.Disengage13 import Network.TLS.Packet import Network.TLS.Hooks import Network.TLS.Sending+import Network.TLS.Sending13 import Network.TLS.Receiving import Network.TLS.Imports+import Network.TLS.Receiving13+import Network.TLS.State import qualified Data.ByteString as B import Data.IORef-import Control.Monad.State.Strict-import Control.Exception (throwIO)+import Control.Monad.Reader+import Control.Exception (finally, throwIO) import System.IO.Error (mkIOError, eofErrorType) checkValid :: Context -> IO () checkValid ctx = do established <- ctxEstablished ctx- unless established $ throwIO ConnectionNotEstablished+ when (established == NotEstablished) $ throwIO ConnectionNotEstablished eofed <- ctxEOF ctx when eofed $ throwIO $ mkIOError eofErrorType "data" Nothing Nothing @@ -80,7 +93,7 @@ case res of Left e -> return $ Left e Right content ->- either (return . Left) (flip getRecord content) $ decodeDeprecatedHeader readlen content+ either (return . Left) (`getRecord` content) $ decodeDeprecatedHeader readlen content #endif maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow) getRecord :: Header -> ByteString -> IO (Either TLSError (Record Plaintext))@@ -88,6 +101,9 @@ withLog ctx $ \logging -> loggingIORecv logging header content runRxState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content) +isCCS :: Record a -> Bool+isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True+isCCS _ = False -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a@@ -99,17 +115,21 @@ case erecord of Left err -> return $ Left err Right record -> do- pktRecv <- processPacket ctx record- 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+ hrr <- usingState_ ctx getTLS13HRR+ if hrr && isCCS record then+ recvPacket ctx+ else do+ pktRecv <- processPacket ctx record+ 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 -- | Send one packet to the context sendPacket :: MonadIO m => Context -> Packet -> m ()@@ -125,8 +145,78 @@ writePacket ctx pkt case edataToSend of Left err -> throwCore err- Right dataToSend -> liftIO $ do- withLog ctx $ \logging -> loggingIOSent logging dataToSend- contextSend ctx dataToSend+ Right dataToSend -> sendBytes ctx dataToSend where isNonNullAppData (AppData b) = not $ B.null b isNonNullAppData _ = False++sendPacket13 :: MonadIO m => Context -> Packet13 -> m ()+sendPacket13 ctx pkt = writePacketBytes13 ctx pkt >>= sendBytes ctx++writePacketBytes13 :: MonadIO m => Context -> Packet13 -> m ByteString+writePacketBytes13 ctx pkt = do+ edataToSend <- liftIO $ do+ withLog ctx $ \logging -> loggingPacketSent logging (show pkt)+ writePacket13 ctx pkt+ either throwCore return edataToSend++sendBytes :: MonadIO m => Context -> ByteString -> m ()+sendBytes ctx dataToSend = liftIO $ do+ withLog ctx $ \logging -> loggingIOSent logging dataToSend+ contextSend ctx dataToSend++recvRecord13 :: Context+ -> IO (Either TLSError Record13)+recvRecord13 ctx = readExact ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ where recvLengthE = either (return . Left) recvLength+ recvLength header@(Header _ _ readlen)+ | readlen > 16384 + 2048 = return $ Left maximumSizeExceeded+ | otherwise =+ readExact ctx (fromIntegral readlen) >>=+ either (return . Left) (getRecord header)+ maximumSizeExceeded = Error_Protocol ("record exceeding maximum size", True, RecordOverflow)+ getRecord :: Header -> ByteString -> IO (Either TLSError Record13)+ getRecord header content = do+ liftIO $ withLog ctx $ \logging -> loggingIORecv logging header content+ runRxState ctx $ disengageRecord13 $ rawToRecord13 header content++recvPacket13 :: MonadIO m => Context -> m (Either TLSError Packet13)+recvPacket13 ctx = liftIO $ do+ erecord <- recvRecord13 ctx+ case erecord of+ Left err@(Error_Protocol (_, True, BadRecordMac)) -> do+ -- If the server decides to reject RTT0 data but accepts RTT1+ -- data, the server should skip all records for RTT0 data.+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed n+ | n > 0 -> do setEstablished ctx $ EarlyDataNotAllowed (n - 1)+ recvPacket13 ctx+ _ -> return $ Left err+ Left err -> return $ Left err+ Right record -> do+ pkt <- processPacket13 ctx record+ case pkt of+ Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p+ _ -> return ()+ return pkt++-- | State monad used to group several packets together and send them on wire as+-- single flight. When packets are loaded in the monad, they are logged+-- 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 a = PacketFlightM (ReaderT (IORef [ByteString]) IO a)+ deriving (Functor, Applicative, Monad, MonadFail, MonadIO)++runPacketFlight :: Context -> PacketFlightM a -> IO a+runPacketFlight ctx (PacketFlightM f) = do+ ref <- newIORef []+ finally (runReaderT f ref) $ do+ st <- readIORef ref+ unless (null st) $ sendBytes ctx $ B.concat $ reverse st++loadPacket13 :: Context -> Packet13 -> PacketFlightM ()+loadPacket13 ctx pkt = PacketFlightM $ do+ bs <- writePacketBytes13 ctx pkt+ ref <- ask+ liftIO $ modifyIORef ref (bs :)
Network/TLS/Imports.hs view
@@ -16,6 +16,9 @@ , module Data.ByteString.Char8 -- instance , module Control.Applicative , module Control.Monad+#if !MIN_VERSION_base(4,13,0)+ , MonadFail+#endif , module Data.Bits , module Data.List , module Data.Maybe@@ -38,6 +41,9 @@ 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)
+ Network/TLS/KeySchedule.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Network.TLS.KeySchedule+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+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++----------------------------------------------------------------++hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString+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"++----------------------------------------------------------------++deriveSecret :: Hash -> ByteString -> ByteString -> ByteString -> ByteString+deriveSecret h secret label hashedMsgs =+ hkdfExpandLabel h secret label hashedMsgs outlen+ where+ outlen = hashDigestSize h++----------------------------------------------------------------++hkdfExpandLabel :: Hash+ -> ByteString+ -> ByteString+ -> ByteString+ -> Int+ -> ByteString+hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen+ where+ hkdfLabel = runPut $ do+ putWord16 $ fromIntegral outlen+ putOpaque8 ("tls13 " `BS.append` label)+ putOpaque8 ctx++expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString+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+expand' _ _ _ _ = error "expand'"++----------------------------------------------------------------
Network/TLS/MAC.hs view
@@ -18,6 +18,7 @@ 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 type HMAC = ByteString -> ByteString -> ByteString@@ -52,7 +53,7 @@ hmacIter f secret seed aprev len = let an = f secret aprev in let out = f secret (B.concat [an, seed]) in- let digestsize = fromIntegral $ B.length out 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)@@ -65,7 +66,7 @@ prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString prf_MD5SHA1 secret seed len =- B.pack $ B.zipWith xor (prf_MD5 s1 seed len) (prf_SHA1 s2 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
Network/TLS/Packet.hs view
@@ -57,6 +57,14 @@ -- * for extensions parsing , getSignatureHashAlgorithm , putSignatureHashAlgorithm+ , getBinaryVersion+ , putBinaryVersion+ , putServerRandom32+ , putExtension+ , getExtensions+ , putSession+ , putDNames+ , getDNames ) where import Network.TLS.Imports@@ -89,8 +97,14 @@ Nothing -> fail ("invalid version : " ++ show major ++ "," ++ show minor) Just v -> return v -putVersion :: Version -> Put-putVersion ver = putWord8 major >> putWord8 minor+getBinaryVersion :: Get (Maybe Version)+getBinaryVersion = do+ major <- getWord8+ minor <- getWord8+ return $ verOfNum (major, minor)++putBinaryVersion :: Version -> Put+putBinaryVersion ver = putWord8 major >> putWord8 minor where (major, minor) = numericalVer ver getHeaderType :: Get ProtocolType@@ -114,7 +128,7 @@ - decode and encode headers -} decodeHeader :: ByteString -> Either TLSError Header-decodeHeader = runGetErr "header" $ liftM3 Header getHeaderType getVersion getWord16+decodeHeader = runGetErr "header" $ Header <$> getHeaderType <*> getVersion <*> getWord16 decodeDeprecatedHeaderLength :: ByteString -> Either TLSError Word16 decodeDeprecatedHeaderLength = runGetErr "deprecatedheaderlength" $ subtract 0x8000 <$> getWord16@@ -127,7 +141,7 @@ return $ Header ProtocolType_DeprecatedHandshake version size encodeHeader :: Header -> ByteString-encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putVersion ver >> putWord16 len)+encodeHeader (Header pt ver len) = runPut (putHeaderType pt >> putBinaryVersion ver >> putWord16 len) {- FIXME check len <= 2^14 -} encodeHeaderNoVer :: Header -> ByteString@@ -152,7 +166,7 @@ r <- remaining if r == 0 then return []- else liftM2 (:) decodeAlert loop+ else (:) <$> decodeAlert <*> loop encodeAlerts :: [(AlertLevel, AlertDescription)] -> ByteString encodeAlerts l = runPut $ mapM_ encodeAlert l@@ -250,21 +264,26 @@ 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))++-- | Decode a list CA distinguished names+getDNames :: Get [DistinguishedName]+getDNames = do dNameLen <- getWord16 -- FIXME: Decide whether to remove this check completely or to make it an option. -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"- dNames <- getList (fromIntegral dNameLen) getDName- return $ CertRequest certTypes sigHashAlgs dNames- where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))- getDName = do- dName <- getOpaque16- when (B.length dName == 0) $ fail "certrequest: invalid DN length"- dn <- case decodeASN1' DER dName of- Left e -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e)- Right asn1s -> case fromASN1 asn1s of- Left e -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e)- Right (d,_) -> return d- return (2 + B.length dName, dn)+ getList (fromIntegral dNameLen) getDName+ where+ getDName = do+ dName <- getOpaque16+ when (B.length dName == 0) $ fail "certrequest: invalid DN length"+ dn <- case decodeASN1' DER dName of+ Left e -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e)+ Right asn1s -> case fromASN1 asn1s of+ Left e -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e)+ Right (d,_) -> return d+ return (2 + B.length dName, dn) decodeCertVerify :: CurrentParams -> Get Handshake decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)@@ -330,7 +349,7 @@ encodeHandshake :: Handshake -> ByteString encodeHandshake o = let content = runPut $ encodeHandshakeContent o in- let len = fromIntegral $ B.length content in+ let len = B.length content in let header = case o of ClientHello _ _ _ _ _ _ (Just _) -> "" -- SSLv2 ClientHello message _ -> runPut $ encodeHandshakeHeader (typeOfHandshake o) len in@@ -347,7 +366,7 @@ encodeHandshakeContent (ClientHello _ _ _ _ _ _ (Just deprecated)) = do putBytes deprecated encodeHandshakeContent (ClientHello version random session cipherIDs compressionIDs exts Nothing) = do- putVersion version+ putBinaryVersion version putClientRandom32 random putSession session putWords16 cipherIDs@@ -355,10 +374,14 @@ putExtensions exts return () -encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) =- putVersion version >> putServerRandom32 random >> putSession session- >> putWord16 cipherid >> putWord8 compressionID- >> putExtensions exts >> return ()+encodeHandshakeContent (ServerHello version random session cipherid compressionID exts) = do+ putBinaryVersion version+ putServerRandom32 random+ putSession session+ putWord16 cipherid+ putWord8 compressionID+ putExtensions exts+ return () encodeHandshakeContent (Certificates cc) = putOpaque24 (runPut $ mapM_ putOpaque24 certs) where (CertificateChainRaw certs) = encodeCertificateChain cc@@ -388,21 +411,25 @@ case sigAlgs of Nothing -> return () Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l- encodeCertAuthorities certAuthorities- where -- Convert a distinguished name to its DER encoding.- encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn-- -- Encode a list of distinguished names.- encodeCertAuthorities certAuths = do- enc <- mapM encodeCA certAuths- let totLength = sum $ map ((+) 2 . B.length) enc- putWord16 (fromIntegral totLength)- mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc+ putDNames certAuthorities encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned encodeHandshakeContent (Finished opaque) = putBytes opaque +------------------------------------------------------------++-- | Encode a list of distinguished names.+putDNames :: [DistinguishedName] -> Put+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+ where+ -- Convert a distinguished name to its DER encoding.+ encodeCA dn = return $ encodeASN1' DER (toASN1 dn [])+ {- FIXME make sure it return error if not 32 available -} getRandom32 :: Get ByteString getRandom32 = getBytes 32@@ -465,6 +492,7 @@ putServerDHParams :: ServerDHParams -> Put putServerDHParams (ServerDHParams p g y) = mapM_ putBigNum16 [p,g,y] +-- RFC 4492 Section 5.4 Server Key Exchange getServerECDHParams :: Get ServerECDHParams getServerECDHParams = do curveType <- getWord8@@ -481,6 +509,7 @@ _ -> 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@@ -511,11 +540,11 @@ -- rsa pre master secret decodePreMasterSecret :: ByteString -> Either TLSError (Version, ByteString)-decodePreMasterSecret = runGetErr "pre-master-secret" $ do- liftM2 (,) getVersion (getBytes 46)+decodePreMasterSecret = runGetErr "pre-master-secret" $+ (,) <$> getVersion <*> getBytes 46 encodePreMasterSecret :: Version -> ByteString -> ByteString-encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes)+encodePreMasterSecret version bytes = runPut (putBinaryVersion version >> putBytes bytes) -- | in certain cases, we haven't manage to decode ServerKeyExchange properly, -- because the decoding was too eager and the cipher wasn't been set yet.@@ -644,6 +673,6 @@ encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams -fromJustM :: Monad m => String -> Maybe a -> m a-fromJustM what Nothing = fail ("fromJust " ++ what ++ ": Nothing")+fromJustM :: MonadFail m => String -> Maybe a -> m a+fromJustM what Nothing = fail ("fromJustM " ++ what ++ ": Nothing") fromJustM _ (Just x) = return x
+ Network/TLS/Packet13.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.TLS.Packet13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Packet13+ ( encodeHandshakes13+ , encodeHandshake13+ , getHandshakeType13+ , decodeHandshakeRecord13+ , decodeHandshake13+ ) where++import qualified Data.ByteString as B+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)++encodeHandshakes13 :: [Handshake13] -> ByteString+encodeHandshakes13 hss = B.concat $ map encodeHandshake13 hss++encodeHandshake13 :: Handshake13 -> ByteString+encodeHandshake13 hdsk = pkt+ where+ !tp = typeOfHandshake13 hdsk+ !content = encodeHandshake13' hdsk+ !len = B.length content+ !header = encodeHandshakeHeader13 tp len+ !pkt = B.concat [header, content]++-- TLS 1.3 does not use "select (extensions_present)".+putExtensions :: [ExtensionRaw] -> Put+putExtensions es = putOpaque16 (runPut $ mapM_ putExtension es)++encodeHandshake13' :: Handshake13 -> ByteString+encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do+ putBinaryVersion TLS12+ putServerRandom32 random+ putSession session+ putWord16 cipherId+ putWord8 0 -- compressionID nullCompression+ putExtensions exts+encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts+encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do+ putOpaque8 reqctx+ putExtensions exts+encodeHandshake13' (Certificate13 reqctx cc ess) = runPut $ do+ putOpaque8 reqctx+ putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)+ where+ CertificateChainRaw certs = encodeCertificateChain cc+ putCert (certRaw,exts) = do+ putOpaque24 certRaw+ putExtensions exts+encodeHandshake13' (CertVerify13 hs signature) = runPut $ do+ putSignatureHashAlgorithm hs+ putOpaque16 signature+encodeHandshake13' (Finished13 dat) = runPut $ putBytes dat+encodeHandshake13' (NewSessionTicket13 life ageadd nonce label exts) = runPut $ do+ putWord32 life+ putWord32 ageadd+ putOpaque8 nonce+ putOpaque16 label+ putExtensions exts+encodeHandshake13' EndOfEarlyData13 = ""+encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0+encodeHandshake13' (KeyUpdate13 UpdateRequested) = runPut $ putWord8 1++encodeHandshake13' _ = error "encodeHandshake13'"++encodeHandshakeHeader13 :: HandshakeType13 -> Int -> ByteString+encodeHandshakeHeader13 ty len = runPut $ do+ putWord8 (valOfType ty)+ putWord24 len+++{- decode and encode HANDSHAKE -}+getHandshakeType13 :: Get HandshakeType13+getHandshakeType13 = do+ ty <- getWord8+ case valToType ty of+ Nothing -> fail ("invalid handshake type: " ++ show ty)+ Just t -> return t++decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType13, ByteString)+decodeHandshakeRecord13 = runGet "handshake-record" $ do+ ty <- getHandshakeType13+ content <- getOpaque24+ return (ty, content)++decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake13+decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of+ 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+ _fixme -> error $ "decodeHandshake13 " ++ show _fixme++decodeFinished13 :: Get Handshake13+decodeFinished13 = Finished13 <$> (remaining >>= getBytes)++decodeEncryptedExtensions13 :: Get Handshake13+decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do+ len <- fromIntegral <$> getWord16+ getExtensions len++decodeCertRequest13 :: Get Handshake13+decodeCertRequest13 = do+ reqctx <- getOpaque8+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ CertRequest13 reqctx exts++decodeCertificate13 :: Get Handshake13+decodeCertificate13 = do+ reqctx <- getOpaque8+ len <- fromIntegral <$> getWord24+ (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+ where+ getCert = do+ l <- fromIntegral <$> getWord24+ cert <- getBytes l+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return (3 + l + 2 + len, (cert, exts))++decodeCertVerify13 :: Get Handshake13+decodeCertVerify13 = CertVerify13 <$> getSignatureHashAlgorithm <*> getOpaque16++decodeNewSessionTicket13 :: Get Handshake13+decodeNewSessionTicket13 = do+ life <- getWord32+ ageadd <- getWord32+ nonce <- getOpaque8+ label <- getOpaque16+ len <- fromIntegral <$> getWord16+ exts <- getExtensions len+ return $ NewSessionTicket13 life ageadd nonce label exts++decodeKeyUpdate13 :: Get Handshake13+decodeKeyUpdate13 = do+ ru <- getWord8+ case ru of+ 0 -> return $ KeyUpdate13 UpdateNotRequested+ 1 -> return $ KeyUpdate13 UpdateRequested+ x -> fail $ "Unknown request_update: " ++ show x
Network/TLS/Parameters.hs view
@@ -12,6 +12,8 @@ , CommonParams , DebugParams(..) , ClientHooks(..)+ , OnCertificateRequest+ , OnServerCertificate , ServerHooks(..) , Supported(..) , Shared(..)@@ -36,10 +38,10 @@ import Network.TLS.X509 import Network.TLS.RNG (Seed) import Network.TLS.Imports+import Network.TLS.Types (HostName) import Data.Default.Class import qualified Data.ByteString as B -type HostName = String type CommonParams = (Supported, Shared, DebugParams) @@ -53,12 +55,18 @@ -- | Add a way to print the seed that was randomly generated. re-using the same seed -- will reproduce the same randomness with 'debugSeed' , debugPrintSeed :: Seed -> IO ()+ -- | Force to choose this version in the server side.+ , debugVersionForced :: Maybe Version+ -- | Printing master keys. The default is no printing.+ , debugKeyLogger :: String -> IO () } defaultDebugParams :: DebugParams defaultDebugParams = DebugParams { debugSeed = Nothing , debugPrintSeed = const (return ())+ , debugVersionForced = Nothing+ , debugKeyLogger = \_ -> return () } instance Show DebugParams where@@ -89,6 +97,10 @@ -- of 'supportedCiphers' with a suitable cipherlist. , clientSupported :: Supported , 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.+ , clientEarlyData :: Maybe ByteString } deriving (Show) defaultParamsClient :: HostName -> ByteString -> ClientParams@@ -101,6 +113,7 @@ , clientHooks = def , clientSupported = def , clientDebug = defaultDebugParams+ , clientEarlyData = Nothing } data ServerParams = ServerParams@@ -125,6 +138,9 @@ , serverHooks :: ServerHooks , serverSupported :: Supported , 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.+ , serverEarlyDataSize :: Int } deriving (Show) defaultParamsServer :: ServerParams@@ -136,6 +152,7 @@ , serverShared = def , serverSupported = def , serverDebug = defaultDebugParams+ , serverEarlyDataSize = 0 } instance Default ServerParams where@@ -152,17 +169,27 @@ -- cipher list. 'Network.TLS.Extra.Cipher.ciphersuite_default' is often -- a good choice. , supportedCiphers :: [Cipher]- -- | supported compressions methods+ -- | 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. , 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 also used to restrict the choice of server- -- credential, signature and hash algorithm, but only when the TLS- -- version is 1.2 or above. In order to disable SHA-1 one must then+ -- 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. , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Secure renegotiation defined in RFC5746. -- If 'True', clients send the renegotiation_info extension.@@ -189,6 +216,11 @@ , 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.+ -- -- The default value is ['X25519','P256','P384','P521']. -- 'X25519' and 'P256' provide 128-bit security which is strong -- enough until 2030. Both curves are fast because their@@ -201,12 +233,17 @@ { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression]- , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA)+ , 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.HashSHA384, SignatureECDSA) , (Struct.HashSHA256, SignatureRSA)- , (Struct.HashSHA256, SignatureECDSA) , (Struct.HashSHA1, SignatureRSA) , (Struct.HashSHA1, SignatureDSS) ]@@ -221,10 +258,33 @@ instance Default Supported where def = defaultSupported +-- | Parameters that are common to clients and servers. data Shared = Shared- { sharedCredentials :: Credentials+ { -- | The list of certificates and private keys that a server will use as+ -- part of authentication to clients. Actual credentials that are used+ -- are selected dynamically from this list based on client capabilities.+ -- Additional credentials returned by 'onServerNameIndication' are also+ -- considered.+ --+ -- When credential list is left empty (the default value), no key+ -- exchange can take place.+ sharedCredentials :: Credentials+ -- | Callbacks used by clients and servers in order to resume TLS+ -- sessions. The default implementation never resumes sessions. Package+ -- <https://hackage.haskell.org/package/tls-session-manager tls-session-manager>+ -- provides an in-memory implementation. , 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+ -- <https://hackage.haskell.org/package/x509-system x509-system>+ -- gives access to a default certificate store configured in the+ -- system. , 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. , sharedValidationCache :: ValidationCache } @@ -246,48 +306,106 @@ | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value deriving (Show,Eq) -defaultGroupUsage :: DHParams -> DHPublic -> IO GroupUsage-defaultGroupUsage params public+defaultGroupUsage :: Int -> DHParams -> DHPublic -> IO GroupUsage+defaultGroupUsage minBits params public | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime" | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator" | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic+ -- To prevent Logjam attack+ | dhParamsGetBits params < minBits = return GroupUsageInsecure | otherwise = return GroupUsageValid +-- | Type for 'onCertificateRequest'. This type synonym is to make+-- document readable.+type OnCertificateRequest = ([CertificateType],+ Maybe [HashAndSignatureAlgorithm],+ [DistinguishedName])+ -> IO (Maybe (CertificateChain, PrivKey))++-- | Type for 'onServerCertificate'. This type synonym is to make+-- document readable.+type OnServerCertificate = CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]+ -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks- { -- | This action is called when the server sends a- -- certificate request. The parameter is the information- -- from the request. The action should select a certificate- -- chain of one of the given certificate types where the- -- last certificate in the chain should be signed by one of- -- the given distinguished names. Each certificate should- -- be signed by the following one, except for the last. At- -- least the first of the certificates in the chain must- -- have a corresponding private key, because that is used- -- for signing the certificate verify message.+ { -- | 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+ -- <https://tools.ietf.org/html/rfc8446#section-4.2.3 RFC 8446>+ -- section 4.2.3. When no compatible certificate chain is+ -- available, return 'Nothing' if it is OK to continue+ -- without a client certificate. Returning a non-matching+ -- certificate should result in a handshake failure.+ --+ -- 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. Returning a non-matching one will- -- lead to handshake failure later.- --- -- Returning a certificate chain not matching the- -- distinguished names may lead to problems or not,- -- depending whether the server accepts it.- onCertificateRequest :: ([CertificateType],- Maybe [HashAndSignatureAlgorithm],- [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey))+ -- certificate types (public key algorithms). Returning+ -- a non-matching one will lead to handshake failure later.+ 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.- , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]+ --+ -- 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.+ , onServerCertificate :: OnServerCertificate -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. , 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".+ -- | This action is called to validate DHE parameters when the server+ -- selected a finite-field group not part of the "Supported Groups+ -- Registry" or not part of 'supportedGroups' list.+ --+ -- With TLS 1.3 custom groups have been removed from the protocol, so+ -- this callback is only used when the version negotiated is 1.2 or+ -- below.+ --+ -- The default behavior with (dh_p, dh_g, dh_size) and pub as follows:+ --+ -- (1) rejecting if dh_p is even+ -- (2) rejecting unless 1 < dh_g && dh_g < dh_p - 1+ -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1+ -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack)+ -- -- See RFC 7919 section 3.1 for recommandations. , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage }@@ -297,7 +415,7 @@ { onCertificateRequest = \ _ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing- , onCustomFFDHEGroup = defaultGroupUsage+ , onCustomFFDHEGroup = defaultGroupUsage 1024 } instance Show ClientHooks where@@ -311,6 +429,10 @@ -- | 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. onClientCertificate :: CertificateChain -> IO CertificateUsage -- | This action is called when the client certificate
+ Network/TLS/Receiving13.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module : Network.TLS.Receiving13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Receiving module contains calls related to unmarshalling packets according+-- to the TLS state+--+module Network.TLS.Receiving13+ ( processPacket13+ ) where++import Control.Monad.State++import Network.TLS.Context.Internal+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.ErrT+import Network.TLS.Record.Types13+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Wire+import Network.TLS.State+import Network.TLS.Util+import Network.TLS.Imports++processPacket13 :: Context -> Record13 -> IO (Either TLSError Packet13)+processPacket13 _ (Record13 ContentType_ChangeCipherSpec _) = return $ Right ChangeCipherSpec13+processPacket13 _ (Record13 ContentType_AppData fragment) = return $ Right $ AppData13 fragment+processPacket13 _ (Record13 ContentType_Alert fragment) = return (Alert13 `fmapEither` decodeAlerts fragment)+processPacket13 ctx (Record13 ContentType_Handshake fragment) = usingState ctx $ do+ mCont <- gets stHandshakeRecordCont13+ modify (\st -> st { stHandshakeRecordCont13 = Nothing })+ hss <- parseMany mCont 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
Network/TLS/Record/Disengage.hs view
@@ -30,7 +30,7 @@ import Network.TLS.Packet import Network.TLS.Imports import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert)+import qualified Data.ByteArray as B (convert, xor) disengageRecord :: Record Ciphertext -> RecordM (Record Plaintext) disengageRecord = decryptRecord >=> uncompressRecord@@ -91,14 +91,14 @@ {- update IV -} (iv, econtent') <- if explicitIV- then get2 econtent (bulkIVSize bulk, econtentLen - bulkIVSize bulk)+ 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) <- get3 content' (contentlen, macSize, paddinglength)+ (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac@@ -112,7 +112,7 @@ let (content', bulkStream') = decryptF econtent {- update Ctx -} let contentlen = B.length content' - macSize- (content, mac) <- get2 content' (contentlen, macSize)+ (content, mac) <- get2i content' (contentlen, macSize) modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } } getCipherData record CipherData { cipherDataContent = content@@ -128,12 +128,16 @@ -- check if we have enough bytes to cover the minimum for this cipher when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError - (enonce, econtent', authTag) <- get3 econtent (nonceExpLen, cipherLen, authTagLen)+ (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 hdr = Header typ v $ fromIntegral cipherLen ad = B.concat [ encodedSeq, encodeHeader hdr ]- nonce = cstIV (stCryptState tst) `B.append` enonce+ 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) $@@ -145,5 +149,11 @@ decryptOf BulkStateUninitialized = throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError) - get3 s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls- get2 s (d1,d2) = get3 s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)+ -- handling of outer format can report errors with Error_Packet+ get3o s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls+ get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)++ -- all format errors related to decrypted content are reported+ -- externally as integrity failures, i.e. BadRecordMac+ get3i s ls = maybe (throwError $ Error_Protocol ("record bad format", True, BadRecordMac)) return $ partition3 s ls+ get2i s (d1,d2) = get3i s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
+ Network/TLS/Record/Disengage13.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module : Network.TLS.Record.Disengage13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Disengage a record from the Record layer.+-- The record is decrypted, checked for integrity and then decompressed.+--+module Network.TLS.Record.Disengage13+ ( disengageRecord13+ ) where++import Control.Monad.State++import Network.TLS.Imports+import Crypto.Cipher.Types (AuthTag(..))+import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.ErrT+import Network.TLS.Record.State+import Network.TLS.Record.Types13+import Network.TLS.Cipher+import Network.TLS.Util+import Network.TLS.Wire+import qualified Data.ByteString as B+import qualified Data.ByteArray as B (convert, xor)++disengageRecord13 :: Record13 -> RecordM Record13+disengageRecord13 record@(Record13 ContentType_AppData e) = do+ st <- get+ case stCipher st of+ Nothing -> return record+ _ -> do+ inner <- decryptData e st+ let (dc,_pad) = B.spanEnd (== 0) inner+ Just (d,c) = B.unsnoc dc+ Just ct = valToType c+ return $ Record13 ct d+disengageRecord13 record = return record++decryptData :: ByteString -> RecordState -> RecordM ByteString+decryptData econtent tst = decryptOf (cstKey cst)+ where cipher = fromJust "cipher" $ stCipher tst+ bulk = cipherBulk cipher+ cst = stCryptState tst+ econtentLen = B.length econtent++ decryptOf :: BulkState -> RecordM ByteString+ decryptOf (BulkStateAEAD decryptF) = do+ let authTagLen = bulkAuthTagLen bulk+ cipherLen = econtentLen - authTagLen++ (econtent', authTag) <- get2o econtent (cipherLen, authTagLen)+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tst+ iv = cstIV cst+ ivlen = B.length iv+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce = B.xor iv sqnc+ additional = "\23\3\3" `B.append` encodeWord16 (fromIntegral econtentLen)+ (content, authTag2) = decryptF nonce econtent' additional++ when (AuthTag (B.convert authTag) /= authTag2) $+ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)+ modify incrRecordState+ return content++ decryptOf _ =+ throwError $ Error_Protocol ("decrypt state uninitialized", True, InternalError)++ -- handling of outer format can report errors with Error_Packet+ get3o s ls = maybe (throwError $ Error_Packet "record bad format 1.3") return $ partition3 s ls+ get2o s (d1,d2) = get3o s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
Network/TLS/Record/Engage.hs view
@@ -25,7 +25,7 @@ import Network.TLS.Packet import Network.TLS.Imports import qualified Data.ByteString as B-import qualified Data.ByteArray as B (convert)+import qualified Data.ByteArray as B (convert, xor) engageRecord :: Record Plaintext -> RecordM (Record Ciphertext) engageRecord = compressRecord >=> encryptRecord@@ -59,7 +59,7 @@ let content' = B.concat [content, digest] encryptStream encryptF content' BulkStateAEAD encryptF ->- encryptAead encryptF content record+ encryptAead (bulkExplicitIV bulk) encryptF content record BulkStateUninitialized -> return content @@ -91,19 +91,26 @@ modify $ \tstate -> tstate { stCryptState = cst { cstKey = BulkStateStream newBulkStream } } return e -encryptAead :: BulkAEAD+encryptAead :: Int+ -> BulkAEAD -> ByteString -> Record Compressed -> RecordM ByteString-encryptAead encryptF content record = do+encryptAead nonceExpLen encryptF content record = do cst <- getCryptState encodedSeq <- encodeWord64 <$> getMacSequence let hdr = recordToHeader record ad = B.concat [encodedSeq, encodeHeader hdr]- nonce = B.concat [cstIV cst, encodedSeq]+ iv = cstIV cst+ ivlen = B.length iv+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce | nonceExpLen == 0 = B.xor iv sqnc+ | otherwise = B.concat [iv, encodedSeq] (e, AuthTag authtag) = encryptF nonce content ad+ econtent | nonceExpLen == 0 = e `B.append` B.convert authtag+ | otherwise = B.concat [encodedSeq, e, B.convert authtag] modify incrRecordState- return $ B.concat [encodedSeq, e, B.convert authtag]+ return econtent getCryptState :: RecordM CryptState getCryptState = stCryptState <$> get
+ Network/TLS/Record/Engage13.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.TLS.Record.Engage13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Engage a record into the Record layer.+-- The record is compressed, added some integrity field, then encrypted.+--+module Network.TLS.Record.Engage13+ ( engageRecord+ ) where++import Control.Monad.State+import Crypto.Cipher.Types (AuthTag(..))++import Network.TLS.Record.State+import Network.TLS.Record.Types13+import Network.TLS.Cipher+import Network.TLS.Wire+import Network.TLS.Struct (valOfType)+import Network.TLS.Struct13+import Network.TLS.Imports+import Network.TLS.Util+import qualified Data.ByteString as B+import qualified Data.ByteArray as B (convert, xor)++engageRecord :: Record13 -> RecordM Record13+engageRecord record@(Record13 ContentType_ChangeCipherSpec _) = return record+engageRecord record@(Record13 ct bytes) = do+ st <- get+ case stCipher st of+ Nothing -> return record+ _ -> do+ ebytes <- encryptContent $ innerPlaintext ct bytes+ return $ Record13 ContentType_AppData ebytes++innerPlaintext :: ContentType -> ByteString -> ByteString+innerPlaintext ct bytes = runPut $ do+ putBytes bytes+ putWord8 $ valOfType ct -- non zero!+ -- fixme: zeros padding++encryptContent :: ByteString -> RecordM ByteString+encryptContent content = do+ st <- get+ let cst = stCryptState st+ case cstKey cst of+ BulkStateBlock _ -> error "encryptContent"+ BulkStateStream _ -> error "encryptContent"+ BulkStateUninitialized -> return content+ BulkStateAEAD encryptF -> do+ encodedSeq <- encodeWord64 <$> getMacSequence+ let iv = cstIV cst+ ivlen = B.length iv+ sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq+ nonce = B.xor iv sqnc+ bulk = cipherBulk $ fromJust "cipher" $ stCipher st+ authTagLen = bulkAuthTagLen bulk+ plainLen = B.length content+ econtentLen = plainLen + authTagLen+ additional = "\23\3\3" `B.append` encodeWord16 (fromIntegral econtentLen)+ (e, AuthTag authtag) = encryptF nonce content additional+ econtent = e `B.append` B.convert authtag+ modify incrRecordState+ return econtent
Network/TLS/Record/State.hs view
@@ -41,6 +41,8 @@ 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)
+ Network/TLS/Record/Types13.hs view
@@ -0,0 +1,24 @@+-- |+-- Module : Network.TLS.Record.Types13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--++module Network.TLS.Record.Types13+ ( Record13(..)+ , rawToRecord13+ ) where++import Network.TLS.Struct13+import Network.TLS.Record.Types (Header(..))+import Network.TLS.Imports++-- | Represent a TLS record.+data Record13 = Record13 !ContentType ByteString deriving (Show,Eq)++-- | turn a header and a fragment into a record+rawToRecord13 :: Header -> ByteString -> Record13+rawToRecord13 (Header pt _ _) fragment = Record13 (protoToContent pt) fragment+-- the second arg should be TLS12.
+ Network/TLS/Sending13.hs view
@@ -0,0 +1,67 @@+-- |+-- Module : Network.TLS.Sending13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- the Sending module contains calls related to marshalling packets according+-- to the TLS state+--+module Network.TLS.Sending13+ ( writePacket13+ , updateHandshake13+ ) where++import Control.Monad.State+import qualified Data.ByteString as B++import Network.TLS.Struct+import Network.TLS.Struct13+import Network.TLS.Record (RecordM)+import Network.TLS.Record.Types13+import Network.TLS.Record.Engage13+import Network.TLS.Packet+import Network.TLS.Packet13+import Network.TLS.Context.Internal+import Network.TLS.Handshake.Random+import Network.TLS.Handshake.State+import Network.TLS.Handshake.State13+import Network.TLS.Wire+import Network.TLS.Imports++makeRecord :: Packet13 -> RecordM Record13+makeRecord pkt = return $ Record13 (contentType pkt) $ writePacketContent pkt+ where writePacketContent (Handshake13 hss) = encodeHandshakes13 hss+ writePacketContent (Alert13 a) = encodeAlerts a+ writePacketContent (AppData13 x) = x+ writePacketContent ChangeCipherSpec13 = encodeChangeCipherSpec++encodeRecord :: Record13 -> RecordM ByteString+encodeRecord (Record13 ct bytes) = return ebytes+ where+ ebytes = runPut $ do+ putWord8 $ fromIntegral $ valOfType ct+ putWord16 0x0303 -- TLS12+ putWord16 $ fromIntegral $ B.length bytes+ putBytes bytes++writePacket13 :: Context -> Packet13 -> IO (Either TLSError ByteString)+writePacket13 ctx pkt@(Handshake13 hss) = do+ forM_ hss $ updateHandshake13 ctx+ prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)+writePacket13 ctx pkt = prepareRecord ctx (makeRecord pkt >>= engageRecord >>= encodeRecord)++prepareRecord :: Context -> RecordM a -> IO (Either TLSError a)+prepareRecord = runTxState++updateHandshake13 :: Context -> Handshake13 -> IO ()+updateHandshake13 ctx hs = usingHState ctx $ do+ when (isHRR hs) wrapAsMessageHash13+ updateHandshakeDigest encoded+ addHandshakeMessage encoded+ where+ encoded = encodeHandshake13 hs++ isHRR (ServerHello13 srand _ _ _) = isHelloRetryRequest srand+ isHRR _ = False
Network/TLS/Session.hs view
@@ -15,16 +15,19 @@ -- | A session manager data SessionManager = SessionManager { -- | used on server side to decide whether to resume a client session.- sessionResume :: SessionID -> IO (Maybe SessionData)+ sessionResume :: SessionID -> IO (Maybe SessionData)+ -- | used on server side to decide whether to resume a client session for TLS 1.3 0RTT. For a given 'SessionID', the implementation must return its 'SessionData' only once and must not return the same 'SessionData' after the call.+ , sessionResumeOnlyOnce :: SessionID -> IO (Maybe SessionData) -- | used when a session is established.- , sessionEstablish :: SessionID -> SessionData -> IO ()+ , sessionEstablish :: SessionID -> SessionData -> IO () -- | used when a session is invalidated.- , sessionInvalidate :: SessionID -> IO ()+ , sessionInvalidate :: SessionID -> IO () } noSessionManager :: SessionManager noSessionManager = SessionManager- { sessionResume = \_ -> return Nothing- , sessionEstablish = \_ _ -> return ()- , sessionInvalidate = \_ -> return ()+ { sessionResume = \_ -> return Nothing+ , sessionResumeOnlyOnce = \_ -> return Nothing+ , sessionEstablish = \_ _ -> return ()+ , sessionInvalidate = \_ -> return () }
Network/TLS/State.hs view
@@ -46,6 +46,16 @@ , getSession , isSessionResuming , isClientContext+ , setExporterMasterSecret+ , getExporterMasterSecret+ , setTLS13KeyShare+ , getTLS13KeyShare+ , setTLS13PreSharedKey+ , getTLS13PreSharedKey+ , setTLS13HRR+ , getTLS13HRR+ , setTLS13Cookie+ , getTLS13Cookie -- * random , genRandom , withRNG@@ -53,8 +63,9 @@ import Network.TLS.Imports import Network.TLS.Struct+import Network.TLS.Struct13 import Network.TLS.RNG-import Network.TLS.Types (Role(..))+import Network.TLS.Types (Role(..), HostName) import Network.TLS.Wire (GetContinuation) import Network.TLS.Extension import qualified Data.ByteString as B@@ -63,8 +74,6 @@ import Crypto.Random import Data.X509 (CertificateChain) -type HostName = String- data TLSState = TLSState { stSession :: Session , stSessionResuming :: Bool@@ -74,6 +83,7 @@ , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, ByteString)) , stNegotiatedProtocol :: Maybe B.ByteString -- ALPN protocol+ , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType13, ByteString)) , stClientALPNSuggest :: Maybe [B.ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat]@@ -82,6 +92,11 @@ , stRandomGen :: StateRNG , stVersion :: Maybe Version , stClientContext :: Role+ , stTLS13KeyShare :: Maybe KeyShare+ , stTLS13PreSharedKey :: Maybe PreSharedKey+ , stTLS13HRR :: !Bool+ , stTLS13Cookie :: Maybe Cookie+ , stExporterMasterSecret :: Maybe ByteString -- TLS 1.3 } newtype TLSSt a = TLSSt { runTLSSt :: ErrT TLSError (State TLSState) a }@@ -106,15 +121,21 @@ , stServerVerifiedData = B.empty , stExtensionALPN = False , stHandshakeRecordCont = Nothing+ , stHandshakeRecordCont13 = Nothing , stNegotiatedProtocol = Nothing , stClientALPNSuggest = Nothing- , stClientGroupSuggest = 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 } updateVerifiedData :: Role -> ByteString -> TLSSt ()@@ -236,3 +257,33 @@ let (a,rng') = withTLSRNG (stRandomGen st) f put (st { stRandomGen = rng' }) return a++setExporterMasterSecret :: ByteString -> TLSSt ()+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 })++getTLS13KeyShare :: TLSSt (Maybe KeyShare)+getTLS13KeyShare = gets stTLS13KeyShare++setTLS13PreSharedKey :: Maybe PreSharedKey -> TLSSt ()+setTLS13PreSharedKey mpsk = modify (\st -> st { stTLS13PreSharedKey = mpsk })++getTLS13PreSharedKey :: TLSSt (Maybe PreSharedKey)+getTLS13PreSharedKey = gets stTLS13PreSharedKey++setTLS13HRR :: Bool -> TLSSt ()+setTLS13HRR b = modify (\st -> st { stTLS13HRR = b })++getTLS13HRR :: TLSSt Bool+getTLS13HRR = gets stTLS13HRR++setTLS13Cookie :: Maybe Cookie -> TLSSt ()+setTLS13Cookie mcookie = modify (\st -> st { stTLS13Cookie = mcookie })++getTLS13Cookie :: TLSSt (Maybe Cookie)+getTLS13Cookie = gets stTLS13Cookie
Network/TLS/Struct.hs view
@@ -18,10 +18,12 @@ , ExtensionID , ExtensionRaw(..) , CertificateType(..)+ , lastSupportedCertificateType , HashAlgorithm(..) , SignatureAlgorithm(..) , HashAndSignatureAlgorithm , DigitallySigned(..)+ , Signature , ProtocolType(..) , TLSError(..) , TLSException(..)@@ -41,8 +43,6 @@ , Header(..) , ServerRandom(..) , ClientRandom(..)- , serverRandom- , clientRandom , FinishedData , SessionID , Session(..)@@ -60,7 +60,6 @@ , typeOfHandshake ) where -import qualified Data.ByteString as B (length) import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..))@@ -82,17 +81,41 @@ , cipherDataPadding :: Maybe ByteString } deriving (Show,Eq) +-- | Some of the IANA registered code points for 'CertificateType' are not+-- currently supported by the library. Nor should they be, they're are either+-- unwise, obsolete or both. There's no point in conveying these to the user+-- in the client certificate request callback. The request callback will be+-- filtered to exclude unsupported values. If the user cannot find a certificate+-- for a supported code point, we'll go ahead without a client certificate and+-- hope for the best, unless the user's callback decides to throw an exception.+-- data CertificateType =- CertificateType_RSA_Sign -- TLS10- | CertificateType_DSS_Sign -- TLS10- | CertificateType_RSA_Fixed_DH -- TLS10- | CertificateType_DSS_Fixed_DH -- TLS10- | CertificateType_RSA_Ephemeral_DH -- TLS12- | CertificateType_DSS_Ephemeral_DH -- TLS12- | CertificateType_fortezza_dms -- TLS12- | CertificateType_Unknown Word8- deriving (Show,Eq)+ CertificateType_RSA_Sign -- ^ TLS10 and up, RFC5246+ | CertificateType_DSS_Sign -- ^ TLS10 and up, RFC5246+ | CertificateType_ECDSA_Sign -- ^ TLS10 and up, RFC8422+ | CertificateType_Ed25519_Sign -- ^ TLS13 and up, synthetic+ | CertificateType_Ed448_Sign -- ^ TLS13 and up, synthetic+ -- | None of the below will ever be presented to the callback. Any future+ -- public key algorithms valid for client certificates go above this line.+ | CertificateType_RSA_Fixed_DH -- Obsolete, unsupported+ | CertificateType_DSS_Fixed_DH -- Obsolete, unsupported+ | CertificateType_RSA_Ephemeral_DH -- Obsolete, unsupported+ | CertificateType_DSS_Ephemeral_DH -- Obsolete, unsupported+ | CertificateType_fortezza_dms -- Obsolete, unsupported+ | CertificateType_RSA_Fixed_ECDH -- Obsolete, unsupported+ | CertificateType_ECDSA_Fixed_ECDH -- Obsolete, unsupported+ | CertificateType_Unknown Word8 -- Obsolete, unsupported+ deriving (Eq, Ord, Show) +-- | Last supported certificate type, no 'CertificateType that+-- compares greater than this one (based on the 'Ord' instance,+-- not on the wire code point) will be reported to the application+-- via the client certificate request callback.+--+lastSupportedCertificateType :: CertificateType+lastSupportedCertificateType = CertificateType_DSS_Sign++ data HashAlgorithm = HashNone | HashMD5@@ -110,16 +133,21 @@ | SignatureRSA | SignatureDSS | SignatureECDSA- | SignatureRSApssSHA256- | SignatureRSApssSHA384- | SignatureRSApssSHA512+ | SignatureRSApssRSAeSHA256+ | SignatureRSApssRSAeSHA384+ | SignatureRSApssRSAeSHA512 | SignatureEd25519 | SignatureEd448+ | SignatureRSApsspssSHA256+ | SignatureRSApsspssSHA384+ | SignatureRSApsspssSHA512 | SignatureOther Word8 deriving (Show,Eq) type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) +------------------------------------------------------------+ type Signature = ByteString data DigitallySigned = DigitallySigned (Maybe HashAndSignatureAlgorithm) Signature@@ -188,15 +216,6 @@ instance Show ExtensionRaw where show (ExtensionRaw eid bs) = "ExtensionRaw " ++ show eid ++ " " ++ showBytesHex bs ++ "" -constrRandom32 :: (ByteString -> a) -> ByteString -> Maybe a-constrRandom32 constr l = if B.length l == 32 then Just (constr l) else Nothing--serverRandom :: ByteString -> Maybe ServerRandom-serverRandom l = constrRandom32 ServerRandom l--clientRandom :: ByteString -> Maybe ClientRandom-clientRandom l = constrRandom32 ClientRandom l- data AlertLevel = AlertLevel_Warning | AlertLevel_Fatal@@ -227,11 +246,14 @@ | InappropriateFallback -- RFC7507 | UserCanceled | NoRenegotiation+ | MissingExtension | UnsupportedExtension | CertificateUnobtainable | UnrecognizedName | BadCertificateStatusResponse | BadCertificateHashValue+ | UnknownPskIdentity+ | CertificateRequired deriving (Show,Eq) data HandshakeType =@@ -343,6 +365,7 @@ numericalVer TLS10 = (3, 1) numericalVer TLS11 = (3, 2) numericalVer TLS12 = (3, 3)+numericalVer TLS13 = (3, 4) verOfNum :: (Word8, Word8) -> Maybe Version verOfNum (2, 0) = Just SSL2@@ -350,6 +373,7 @@ verOfNum (3, 1) = Just TLS10 verOfNum (3, 2) = Just TLS11 verOfNum (3, 3) = Just TLS12+verOfNum (3, 4) = Just TLS13 verOfNum _ = Nothing class TypeValuable a where@@ -453,11 +477,14 @@ valOfType InappropriateFallback = 86 valOfType UserCanceled = 90 valOfType NoRenegotiation = 100+ valOfType MissingExtension = 109 valOfType UnsupportedExtension = 110 valOfType CertificateUnobtainable = 111 valOfType UnrecognizedName = 112 valOfType BadCertificateStatusResponse = 113 valOfType BadCertificateHashValue = 114+ valOfType UnknownPskIdentity = 115+ valOfType CertificateRequired = 116 valToType 0 = Just CloseNotify valToType 10 = Just UnexpectedMessage@@ -483,22 +510,34 @@ valToType 86 = Just InappropriateFallback valToType 90 = Just UserCanceled valToType 100 = Just NoRenegotiation+ valToType 109 = Just MissingExtension valToType 110 = Just UnsupportedExtension valToType 111 = Just CertificateUnobtainable valToType 112 = Just UnrecognizedName valToType 113 = Just BadCertificateStatusResponse valToType 114 = Just BadCertificateHashValue+ valToType 115 = Just UnknownPskIdentity+ valToType 116 = Just CertificateRequired valToType _ = Nothing instance TypeValuable CertificateType where valOfType CertificateType_RSA_Sign = 1+ valOfType CertificateType_ECDSA_Sign = 64 valOfType CertificateType_DSS_Sign = 2 valOfType CertificateType_RSA_Fixed_DH = 3 valOfType CertificateType_DSS_Fixed_DH = 4 valOfType CertificateType_RSA_Ephemeral_DH = 5 valOfType CertificateType_DSS_Ephemeral_DH = 6 valOfType CertificateType_fortezza_dms = 20+ valOfType CertificateType_RSA_Fixed_ECDH = 65+ valOfType CertificateType_ECDSA_Fixed_ECDH = 66 valOfType (CertificateType_Unknown i) = i+ -- | There are no code points that map to the below synthetic types, these+ -- are inferred indirectly from the @signature_algorithms@ extension of the+ -- TLS 1.3 @CertificateRequest@ message. the value assignments are there+ -- only to avoid partial function warnings.+ valOfType CertificateType_Ed25519_Sign = 0+ valOfType CertificateType_Ed448_Sign = 0 valToType 1 = Just CertificateType_RSA_Sign valToType 2 = Just CertificateType_DSS_Sign@@ -507,7 +546,17 @@ valToType 5 = Just CertificateType_RSA_Ephemeral_DH valToType 6 = Just CertificateType_DSS_Ephemeral_DH valToType 20 = Just CertificateType_fortezza_dms+ valToType 64 = Just CertificateType_ECDSA_Sign+ valToType 65 = Just CertificateType_RSA_Fixed_ECDH+ valToType 66 = Just CertificateType_ECDSA_Fixed_ECDH valToType i = Just (CertificateType_Unknown i)+ -- | There are no code points that map to the below synthetic types, these+ -- are inferred indirectly from the @signature_algorithms@ extension of the+ -- TLS 1.3 @CertificateRequest@ message.+ -- @+ -- CertificateType_Ed25519_Sign+ -- CertificateType_Ed448_Sign+ -- @ instance TypeValuable HashAlgorithm where valOfType HashNone = 0@@ -531,27 +580,33 @@ valToType i = Just (HashOther i) instance TypeValuable SignatureAlgorithm where- valOfType SignatureAnonymous = 0- valOfType SignatureRSA = 1- valOfType SignatureDSS = 2- valOfType SignatureECDSA = 3- valOfType SignatureRSApssSHA256 = 4- valOfType SignatureRSApssSHA384 = 5- valOfType SignatureRSApssSHA512 = 6- valOfType SignatureEd25519 = 7- valOfType SignatureEd448 = 8- valOfType (SignatureOther i) = i+ 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 SignatureRSApssSHA256- valToType 5 = Just SignatureRSApssSHA384- valToType 6 = Just SignatureRSApssSHA512- valToType 7 = Just SignatureEd25519- valToType 8 = Just SignatureEd448- valToType i = Just (SignatureOther i)+ valToType 0 = Just SignatureAnonymous+ valToType 1 = Just SignatureRSA+ valToType 2 = Just SignatureDSS+ valToType 3 = Just SignatureECDSA+ valToType 4 = Just SignatureRSApssRSAeSHA256+ valToType 5 = Just SignatureRSApssRSAeSHA384+ valToType 6 = Just SignatureRSApssRSAeSHA512+ valToType 7 = Just SignatureEd25519+ valToType 8 = Just SignatureEd448+ valToType 9 = Just SignatureRSApsspssSHA256+ valToType 10 = Just SignatureRSApsspssSHA384+ valToType 11 = Just SignatureRSApsspssSHA512+ valToType i = Just (SignatureOther i) instance EnumSafe16 Group where fromEnumSafe16 P256 = 23
+ Network/TLS/Struct13.hs view
@@ -0,0 +1,132 @@+-- |+-- Module : Network.TLS.Struct13+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Network.TLS.Struct13+ ( Packet13(..)+ , Handshake13(..)+ , HandshakeType13(..)+ , typeOfHandshake13+ , ContentType(..)+ , contentType+ , protoToContent+ , KeyUpdate(..)+ ) where++import Data.X509 (CertificateChain)+import Network.TLS.Struct+import Network.TLS.Types+import Network.TLS.Imports++data Packet13 =+ Handshake13 [Handshake13]+ | Alert13 [(AlertLevel, AlertDescription)]+ | ChangeCipherSpec13+ | AppData13 ByteString+ deriving (Show,Eq)++data KeyUpdate = UpdateNotRequested+ | UpdateRequested+ deriving (Show,Eq)++type TicketNonce = ByteString+type CertReqContext = ByteString++-- fixme: convert Word32 to proper data type+data Handshake13 =+ ClientHello13 !Version !ClientRandom !Session ![CipherID] [ExtensionRaw]+ | ServerHello13 !ServerRandom !Session !CipherID [ExtensionRaw]+ | NewSessionTicket13 Second Word32 TicketNonce SessionID [ExtensionRaw]+ | EndOfEarlyData13+ | EncryptedExtensions13 [ExtensionRaw]+ | CertRequest13 CertReqContext [ExtensionRaw]+ | Certificate13 CertReqContext CertificateChain [[ExtensionRaw]]+ | CertVerify13 HashAndSignatureAlgorithm Signature+ | Finished13 FinishedData+ | KeyUpdate13 KeyUpdate+ deriving (Show,Eq)++data HandshakeType13 =+ HandshakeType_ClientHello13+ | HandshakeType_ServerHello13+ | HandshakeType_EndOfEarlyData13+ | HandshakeType_NewSessionTicket13+ | HandshakeType_EncryptedExtensions13+ | HandshakeType_CertRequest13+ | HandshakeType_Certificate13+ | HandshakeType_CertVerify13+ | HandshakeType_Finished13+ | HandshakeType_KeyUpdate13+ deriving (Show,Eq)++typeOfHandshake13 :: Handshake13 -> HandshakeType13+typeOfHandshake13 ClientHello13{} = HandshakeType_ClientHello13+typeOfHandshake13 ServerHello13{} = HandshakeType_ServerHello13+typeOfHandshake13 EndOfEarlyData13{} = HandshakeType_EndOfEarlyData13+typeOfHandshake13 NewSessionTicket13{} = HandshakeType_NewSessionTicket13+typeOfHandshake13 EncryptedExtensions13{} = HandshakeType_EncryptedExtensions13+typeOfHandshake13 CertRequest13{} = HandshakeType_CertRequest13+typeOfHandshake13 Certificate13{} = HandshakeType_Certificate13+typeOfHandshake13 CertVerify13{} = HandshakeType_CertVerify13+typeOfHandshake13 Finished13{} = HandshakeType_Finished13+typeOfHandshake13 KeyUpdate13{} = HandshakeType_KeyUpdate13++instance TypeValuable HandshakeType13 where+ valOfType HandshakeType_ClientHello13 = 1+ valOfType HandshakeType_ServerHello13 = 2+ valOfType HandshakeType_NewSessionTicket13 = 4+ valOfType HandshakeType_EndOfEarlyData13 = 5+ valOfType HandshakeType_EncryptedExtensions13 = 8+ valOfType HandshakeType_CertRequest13 = 13+ valOfType HandshakeType_Certificate13 = 11+ valOfType HandshakeType_CertVerify13 = 15+ valOfType HandshakeType_Finished13 = 20+ valOfType HandshakeType_KeyUpdate13 = 24++ 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++data ContentType =+ ContentType_ChangeCipherSpec+ | ContentType_Alert+ | ContentType_Handshake+ | ContentType_AppData+ deriving (Eq, Show)+++instance TypeValuable ContentType where+ valOfType ContentType_ChangeCipherSpec = 20+ valOfType ContentType_Alert = 21+ valOfType ContentType_Handshake = 22+ valOfType ContentType_AppData = 23++ valToType 20 = Just ContentType_ChangeCipherSpec+ valToType 21 = Just ContentType_Alert+ valToType 22 = Just ContentType_Handshake+ valToType 23 = Just ContentType_AppData+ valToType _ = Nothing++contentType :: Packet13 -> ContentType+contentType ChangeCipherSpec13 = ContentType_ChangeCipherSpec+contentType (Handshake13 _) = ContentType_Handshake+contentType (Alert13 _) = ContentType_Alert+contentType (AppData13 _) = ContentType_AppData++protoToContent :: ProtocolType -> ContentType+protoToContent ProtocolType_ChangeCipherSpec = ContentType_ChangeCipherSpec+protoToContent ProtocolType_Alert = ContentType_Alert+protoToContent ProtocolType_Handshake = ContentType_Handshake+protoToContent ProtocolType_AppData = ContentType_AppData+protoToContent _ = error "protoToContent"
Network/TLS/Types.hs view
@@ -9,21 +9,28 @@ ( Version(..) , SessionID , SessionData(..)+ , TLS13TicketInfo(..) , CipherID , CompressionID , Role(..) , invertRole , Direction(..)+ , HostName+ , Second+ , Millisecond ) where import Network.TLS.Imports+import Network.TLS.Crypto.Types (Group) -type HostName = String+type HostName = String+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 deriving (Show, Eq, Ord, Bounded)+data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 | TLS13 deriving (Show, Eq, Ord, Bounded) -- | A session ID type SessionID = ByteString@@ -35,7 +42,18 @@ , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName , sessionSecret :: ByteString+ , sessionGroup :: Maybe Group+ , sessionTicketInfo :: Maybe TLS13TicketInfo+ , sessionALPN :: Maybe ByteString+ , sessionMaxEarlyDataSize :: Int } deriving (Show,Eq)++data TLS13TicketInfo = TLS13TicketInfo+ { lifetime :: Second -- NewSessionTicket.ticket_lifetime in seconds+ , ageAdd :: Second -- NewSessionTicket.ticket_age_add+ , txrxTime :: Millisecond -- serverSendTime or clientReceiveTime+ , estimatedRTT :: Maybe Millisecond+ } deriving (Show, Eq) -- | Cipher identification type CipherID = Word16
Network/TLS/Util.hs view
@@ -5,13 +5,14 @@ , partition3 , partition6 , fromJust- , and' , (&&!) , bytesEq , fmapEither , catchException+ , mapChunks_ ) where +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Imports @@ -52,10 +53,6 @@ fromJust what Nothing = error ("fromJust " ++ what ++ ": Nothing") -- yuck fromJust _ (Just x) = x --- | This is a strict version of and-and' :: [Bool] -> Bool-and' l = foldl' (&&!) True l- -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool True &&! True = True@@ -67,12 +64,18 @@ -- it's a non lazy version, that will compare every bytes. -- arguments with different length will bail out early bytesEq :: ByteString -> ByteString -> Bool-bytesEq b1 b2- | B.length b1 /= B.length b2 = False- | otherwise = and' $ B.zipWith (==) b1 b2+bytesEq = BA.constEq fmapEither :: (a -> b) -> Either l a -> Either l b fmapEither f = fmap f catchException :: IO a -> (SomeException -> IO a) -> IO a catchException action handler = withAsync action waitCatch >>= either handler return++mapChunks_ :: Monad m+ => Int -> (B.ByteString -> m a) -> B.ByteString -> m ()+mapChunks_ len f bs+ | B.length bs > len =+ let (chunk, remain) = B.splitAt len bs+ in f chunk >> mapChunks_ len f remain+ | otherwise = void (f bs)
Network/TLS/Wire.hs view
@@ -23,6 +23,7 @@ , getWords16 , getWord24 , getWord32+ , getWord64 , getBytes , getOpaque8 , getOpaque16@@ -40,6 +41,7 @@ , putWords16 , putWord24 , putWord32+ , putWord64 , putBytes , putOpaque8 , putOpaque16@@ -106,6 +108,9 @@ getWord32 :: Get Word32 getWord32 = getWord32be +getWord64 :: Get Word64+getWord64 = getWord64be+ getOpaque8 :: Get ByteString getOpaque8 = getWord8 >>= getBytes . fromIntegral @@ -141,6 +146,9 @@ putWord32 :: Word32 -> Put putWord32 = putWord32be++putWord64 :: Word64 -> Put+putWord64 = putWord64be putWords16 :: [Word16] -> Put putWords16 l = do
Tests/Certificate.hs view
@@ -4,6 +4,8 @@ module Certificate ( arbitraryX509 , arbitraryX509WithKey+ , arbitraryX509WithKeyAndUsage+ , arbitraryKeyUsage , simpleCertificate , simpleX509 ) where@@ -44,12 +46,12 @@ maxSerial :: Integer maxSerial = 16777216 -arbitraryCertificate :: PubKey -> Gen Certificate-arbitraryCertificate pubKey = do+arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate+arbitraryCertificate usageFlags pubKey = do serial <- choose (0,maxSerial) subjectdn <- arbitraryDN validity <- (,) <$> arbitrary <*> arbitrary- let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey)+ let sigalg = getSignatureALG pubKey return $ Certificate { certVersion = 3 , certSerial = serial@@ -59,7 +61,7 @@ , certValidity = validity , certPubKey = pubKey , certExtensions = Extensions $ Just- [ extensionEncode True $ ExtKeyUsage [KeyUsage_digitalSignature,KeyUsage_keyEncipherment,KeyUsage_keyCertSign]+ [ extensionEncode True $ ExtKeyUsage usageFlags ] } where issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")]@@ -69,7 +71,7 @@ Certificate { certVersion = 3 , certSerial = 0- , certSignatureAlg = SignatureALG HashSHA1 (pubkeyToAlg pubKey)+ , certSignatureAlg = getSignatureALG pubKey , certIssuerDN = simpleDN , certSubjectDN = simpleDN , certValidity = (time1, time2)@@ -83,18 +85,21 @@ simpleDN = DistinguishedName [] simpleX509 :: PubKey -> SignedCertificate-simpleX509 pubKey = do+simpleX509 pubKey = let cert = simpleCertificate pubKey sig = replicate 40 1- sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey)+ sigalg = getSignatureALG pubKey (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig,sigalg,())) cert in signedExact arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate-arbitraryX509WithKey (pubKey, _) = do- cert <- arbitraryCertificate pubKey+arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage++arbitraryX509WithKeyAndUsage :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate+arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do+ cert <- arbitraryCertificate usageFlags pubKey sig <- resize 40 $ listOf1 arbitrary- let sigalg = SignatureALG HashSHA1 (pubkeyToAlg pubKey)+ let sigalg = getSignatureALG pubKey let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig,sigalg,())) cert return signedExact @@ -102,3 +107,20 @@ arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)++arbitraryKeyUsage :: Gen [ExtKeyUsageFlag]+arbitraryKeyUsage = sublistOf knownKeyUsage++knownKeyUsage :: [ExtKeyUsageFlag]+knownKeyUsage = [ KeyUsage_digitalSignature+ , KeyUsage_keyEncipherment+ , KeyUsage_keyAgreement+ ]++getSignatureALG :: PubKey -> SignatureALG+getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA+getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA+getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC+getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519+getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448+getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey
Tests/Connection.hs view
@@ -6,16 +6,26 @@ , arbitraryVersions , arbitraryHashSignatures , arbitraryGroups+ , arbitraryKeyUsage , arbitraryPairParams+ , arbitraryPairParams13 , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential+ , arbitraryCredentialsOfEachCurve+ , arbitraryRSACredentialWithUsage+ , dhParamsGroup+ , isVersionEnabled , isCustomDHParams- , leafPublicKey- , oneSessionManager- , setPairParamsSessionManager+ , isLeafRSA+ , isCredentialDSA+ , readClientSessionRef+ , twoSessionRefs+ , twoSessionManagers+ , setPairParamsSessionManagers , setPairParamsSessionResuming , establishDataPipe , initiateDataPipe+ , byeBye ) where import Test.Tasty.QuickCheck@@ -28,9 +38,11 @@ import Data.Default.Class import Data.IORef import Control.Applicative+import Control.Concurrent.Async import Control.Concurrent.Chan import Control.Concurrent import qualified Control.Exception as E+import Control.Monad (unless, when) import Data.List (isInfixOf) import qualified Data.ByteString as B@@ -39,7 +51,7 @@ debug = False knownCiphers :: [Cipher]-knownCiphers = filter nonECDSA (ciphersuite_all ++ ciphersuite_weak)+knownCiphers = ciphersuite_all ++ ciphersuite_weak where ciphersuite_weak = [ cipher_DHE_DSS_RC4_SHA1@@ -47,14 +59,12 @@ , cipher_null_MD5 , cipher_null_SHA1 ]- -- arbitraryCredentialsOfEachType cannot generate ECDSA- nonECDSA c = not ("ECDSA" `isInfixOf` cipherName c) arbitraryCiphers :: Gen [Cipher] arbitraryCiphers = listOf1 $ elements knownCiphers knownVersions :: [Version]-knownVersions = [SSL3,TLS10,TLS11,TLS12]+knownVersions = [SSL3,TLS10,TLS11,TLS12,TLS13] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions@@ -62,7 +72,11 @@ knownHashSignatures :: [HashAndSignatureAlgorithm] knownHashSignatures = filter nonECDSA availableHashSignatures where- availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssSHA256)+ availableHashSignatures = [(TLS.HashIntrinsic, SignatureRSApssRSAeSHA512)+ ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA384)+ ,(TLS.HashIntrinsic, SignatureRSApssRSAeSHA256)+ ,(TLS.HashIntrinsic, SignatureEd25519)+ ,(TLS.HashIntrinsic, SignatureEd448) ,(TLS.HashSHA512, SignatureRSA) ,(TLS.HashSHA512, SignatureECDSA) ,(TLS.HashSHA384, SignatureRSA)@@ -75,62 +89,122 @@ -- arbitraryCredentialsOfEachType cannot generate ECDSA nonECDSA (_,s) = s /= SignatureECDSA -arbitraryHashSignatures :: Gen [HashAndSignatureAlgorithm]-arbitraryHashSignatures = sublistOf knownHashSignatures+knownHashSignatures13 :: [HashAndSignatureAlgorithm]+knownHashSignatures13 = filter compat knownHashSignatures+ where+ compat (h,s) = h /= TLS.HashSHA1 && s /= SignatureDSS && s /= SignatureRSA +arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm]+arbitraryHashSignatures v = sublistOf l+ where l = if v < TLS13 then knownHashSignatures else knownHashSignatures13++-- for performance reason P521, FFDHE6144, FFDHE8192 are not tested knownGroups, knownECGroups, knownFFGroups :: [Group]-knownECGroups = [P256,P384,P521,X25519,X448]-knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192]+knownECGroups = [P256,P384,X25519,X448]+knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096] knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] arbitraryGroups = listOf1 $ elements knownGroups +isCredentialDSA :: (CertificateChain, PrivKey) -> Bool+isCredentialDSA (_, PrivKeyDSA _) = True+isCredentialDSA _ = False+ arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = do let (pubKey, privKey) = getGlobalRSAPair (dsaPub, dsaPriv) <- arbitraryDSAPair+ (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)+ , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv)+ , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) ] +arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)]+arbitraryCredentialsOfEachCurve = do+ (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)+ ]++dhParamsGroup :: DHParams -> Maybe Group+dhParamsGroup params+ | params == ffdhe2048 = Just FFDHE2048+ | params == ffdhe3072 = Just FFDHE3072+ | otherwise = Nothing+ isCustomDHParams :: DHParams -> Bool-isCustomDHParams params = params == dhParams+isCustomDHParams params = params == dhParams512 leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf) +isLeafRSA :: Maybe CertificateChain -> Bool+isLeafRSA chain = case chain >>= leafPublicKey of+ Just (PubKeyRSA _) -> True+ _ -> False+ arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat`- (\cs -> or [maybe True (<= connectVersion) (cipherMinVer x) | x <- cs])+ (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers &&- maybe True (<= connectVersion) (cipherMinVer x) | x <- cs])+ cipherAllowedForVersion connectVersion x | x <- cs]) return (clientCiphers, serverCiphers) arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = do connectVersion <- elements knownVersions (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion- -- The shared ciphers may set a floor on the compatible protocol versions+ -- The shared ciphers may add constraints on the compatible protocol versions let allowedVersions = [ v | v <- knownVersions, or [ x `elem` serverCiphers &&- maybe True (<= v) (cipherMinVer x) | x <- clientCiphers ]]+ cipherAllowedForVersion v x | x <- clientCiphers ]] serAllowedVersions <- (:[]) `fmap` elements allowedVersions arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) -arbitraryECGroupPair :: Gen ([Group], [Group])-arbitraryECGroupPair = do- let arbitraryECGroups = listOf1 $ elements knownECGroups- serverGroups <- arbitraryECGroups- clientGroups <- arbitraryECGroups `suchThat` any (`elem` serverGroups)+-- pair of groups so that at least one EC and one FF group are in common+arbitraryGroupPair :: Gen ([Group], [Group])+arbitraryGroupPair = do+ (serverECGroups, clientECGroups) <- arbitraryGroupPairFrom knownECGroups+ (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups+ serverGroups <- shuffle (serverECGroups ++ serverFFGroups)+ clientGroups <- shuffle (clientECGroups ++ clientFFGroups) return (clientGroups, serverGroups)+ where+ arbitraryGroupPairFrom list = do+ s <- arbitraryGroupsFrom list+ c <- arbitraryGroupsFrom list `suchThat` any (`elem` s)+ return (c, s)+ arbitraryGroupsFrom list = listOf1 $ elements list +arbitraryPairParams13 :: Gen (ClientParams, ServerParams)+arbitraryPairParams13 = arbitraryPairParamsAt TLS13++arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams)+arbitraryPairParamsAt connectVersion = do+ let allowedVersions = [connectVersion]+ serAllowedVersions = [connectVersion]+ (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion+ arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers)++isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool+isVersionEnabled ver (cparams, sparams) =+ (ver `elem` supportedVersions (serverSupported sparams)) &&+ (ver `elem` supportedVersions (clientSupported cparams))+ arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) arbitraryHashSignaturePair = do serverHashSignatures <- shuffle knownHashSignatures@@ -142,10 +216,10 @@ -> Gen (ClientParams, ServerParams) arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do secNeg <- arbitrary- dhparams <- elements [dhParams,ffdhe2048,ffdhe3072]+ dhparams <- elements [dhParams512,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType- (clientGroups, serverGroups) <- arbitraryECGroupPair+ (clientGroups, serverGroups) <- arbitraryGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers@@ -172,28 +246,48 @@ } return (clientState, serverState) -arbitraryClientCredential :: Gen Credential-arbitraryClientCredential = arbitraryCredentialsOfEachType >>= elements+arbitraryClientCredential :: Version -> Gen Credential+arbitraryClientCredential SSL3 = do+ -- for SSL3 there is no EC but only RSA/DSA+ creds <- arbitraryCredentialsOfEachType+ elements (take 2 creds) -- RSA and DSA, but not Ed25519 and Ed448+arbitraryClientCredential _ = arbitraryCredentialsOfEachType >>= elements +arbitraryRSACredentialWithUsage :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey)+arbitraryRSACredentialWithUsage usageFlags = do+ let (pubKey, privKey) = getGlobalRSAPair+ cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ())+ return (CertificateChain [cert], PrivKeyRSA privKey)++readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient+readClientSessionRef refs = readIORef (fst refs)++twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server))+twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing+ -- | simple session manager to store one session id and session data for a single thread. -- a Real concurrent session manager would use an MVar and have multiples items. oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager oneSessionManager ref = SessionManager- { sessionResume = \myId -> (>>= maybeResume myId) <$> readIORef ref- , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat)- , sessionInvalidate = \_ -> return ()+ { 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 myId (sid, sdata)- | sid == myId = Just sdata- | otherwise = Nothing+ maybeResume onlyOnce myId (Just (sid, sdata))+ | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata)+ maybeResume _ _ _ = return Nothing -setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)-setPairParamsSessionManager manager (clientState, serverState) = (nc,ns)- where nc = clientState { clientShared = updateSessionManager $ clientShared clientState }- ns = serverState { serverShared = updateSessionManager $ serverShared serverState }- updateSessionManager shared = shared { sharedSessionManager = manager }+twoSessionManagers :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) -> (SessionManager, SessionManager)+twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) +setPairParamsSessionManagers :: (SessionManager, SessionManager) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)+setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc,ns)+ where nc = clientState { clientShared = updateSessionManager clientManager $ clientShared clientState }+ ns = serverState { serverShared = updateSessionManager serverManager $ serverShared serverState }+ updateSessionManager manager shared = shared { sharedSessionManager = manager }+ setPairParamsSessionResuming :: (SessionID, SessionData) -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionResuming sessionStuff (clientState, serverState) = ( clientState { clientWantSessionResume = Just sessionStuff }@@ -220,22 +314,23 @@ , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) } else def -establishDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> IO (Chan start, Chan result)+establishDataPipe :: (ClientParams, ServerParams) -> (Context -> Chan result -> IO ()) -> (Chan start -> Context -> IO ()) -> IO (start -> IO (), IO result) establishDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe- _ <- (runPipe pipe)+ _ <- runPipe pipe startQueue <- newChan resultQueue <- newChan (cCtx, sCtx) <- newPairContext pipe params - _ <- forkIO $ E.catch (tlsServer sCtx resultQueue)- (printAndRaise "server" (serverSupported $ snd params))- _ <- forkIO $ E.catch (tlsClient startQueue cCtx)- (printAndRaise "client" (clientSupported $ fst params))+ sAsync <- async $ E.catch (tlsServer sCtx resultQueue)+ (printAndRaise "server" (serverSupported $ snd params))+ cAsync <- async $ E.catch (tlsClient startQueue cCtx)+ (printAndRaise "client" (clientSupported $ fst params)) - return (startQueue, resultQueue)+ let readResult = waitBoth cAsync sAsync >> readChan resultQueue+ return (writeChan startQueue, readResult) where printAndRaise :: String -> Supported -> E.SomeException -> IO () printAndRaise s supported e = do@@ -247,23 +342,23 @@ initiateDataPipe params tlsServer tlsClient = do -- initial setup pipe <- newPipe- _ <- (runPipe pipe)- cQueue <- newChan- sQueue <- newChan+ _ <- runPipe pipe (cCtx, sCtx) <- newPairContext pipe params - _ <- forkIO $ E.catch (tlsServer sCtx >>= writeSuccess sQueue)- (writeException sQueue)- _ <- forkIO $ E.catch (tlsClient cCtx >>= writeSuccess cQueue)- (writeException cQueue)-- sRes <- readChan sQueue- cRes <- readChan cQueue- return (cRes, sRes)- where- writeException :: Chan (Either E.SomeException a) -> E.SomeException -> IO ()- writeException queue e = writeChan queue (Left e)+ async (tlsServer sCtx) >>= \sAsync ->+ async (tlsClient cCtx) >>= \cAsync -> do+ sRes <- waitCatch sAsync+ cRes <- waitCatch cAsync+ return (cRes, sRes) - writeSuccess :: Chan (Either E.SomeException a) -> a -> IO ()- writeSuccess queue res = writeChan queue (Right res)+-- Terminate the write direction and wait to receive the peer EOF. This is+-- necessary in situations where we want to confirm the peer status, or to make+-- sure to receive late messages like session tickets. In the test suite this+-- is used each time application code ends the connection without prior call to+-- 'recvData'.+byeBye :: Context -> IO ()+byeBye ctx = do+ bye ctx+ bs <- recvData ctx+ unless (B.null bs) $ fail "byeBye: unexpected application data"
Tests/Marshalling.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Marshalling where @@ -30,16 +29,16 @@ arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ClientRandom where- arbitrary = ClientRandom <$> (genByteString 32)+ arbitrary = ClientRandom <$> genByteString 32 instance Arbitrary ServerRandom where- arbitrary = ServerRandom <$> (genByteString 32)+ arbitrary = ServerRandom <$> genByteString 32 instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of- 2 -> liftM (Session . Just) (genByteString 32)+ 2 -> Session . Just <$> genByteString 32 _ -> return $ Session Nothing instance Arbitrary DigitallySigned where@@ -52,7 +51,7 @@ arbitraryCompressionIDs = choose (0,200) >>= vector someWords8 :: Int -> Gen [Word8]-someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))+someWords8 = vector instance Arbitrary CertificateType where arbitrary = elements@@ -69,32 +68,32 @@ <*> arbitrary <*> arbitraryCiphersIDs <*> arbitraryCompressionIDs- <*> (return [])- <*> (return Nothing)+ <*> return []+ <*> return Nothing , ServerHello <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary- <*> (return [])- , liftM Certificates (CertificateChain <$> (resize 2 $ listOf $ arbitraryX509))+ <*> return []+ , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) , pure HelloRequest , pure ServerHelloDone , ClientKeyXchg . CKX_RSA <$> genByteString 48 --, liftM ServerKeyXchg , liftM3 CertRequest arbitrary (return Nothing) (return []) , CertVerify <$> arbitrary- , Finished <$> (genByteString 12)+ , Finished <$> genByteString 12 ] {- quickcheck property -} prop_header_marshalling_id :: Header -> Bool-prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x+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+prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x where decodeHs b = case decodeHandshakeRecord b of GotPartial _ -> error "got partial" GotError e -> error ("got error: " ++ show e)
Tests/PubKey.hs view
@@ -1,19 +1,27 @@ module PubKey ( arbitraryRSAPair , arbitraryDSAPair+ , arbitraryEd25519Pair+ , arbitraryEd448Pair , globalRSAPair , getGlobalRSAPair- , dhParams+ , dhParams512+ , dhParams768+ , dhParams1024 , dsaParams , rsaParams ) where import Test.Tasty.QuickCheck +import qualified Data.ByteString as B import qualified Crypto.PubKey.DH as DH+import Crypto.Error import Crypto.Random import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448 import Control.Concurrent.MVar import System.IO.Unsafe@@ -52,13 +60,29 @@ e = 0x10001 d = 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 -dhParams :: DH.Params-dhParams = DH.Params+dhParams512 :: DH.Params+dhParams512 = DH.Params { DH.params_p = 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb , DH.params_g = 0x2 , DH.params_bits = 512 } +-- from RFC 2409++dhParams768 :: DH.Params+dhParams768 = DH.Params+ { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff+ , DH.params_g = 0x2+ , DH.params_bits = 768+ }++dhParams1024 :: DH.Params+dhParams1024 = DH.Params+ { DH.params_p = 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff+ , DH.params_g = 0x2+ , DH.params_bits = 1024+ }+ dsaParams :: DSA.Params dsaParams = DSA.Params { DSA.params_p = 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb@@ -71,3 +95,15 @@ priv <- choose (1, DSA.params_q dsaParams) let pub = DSA.calculatePublic dsaParams priv return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv)++arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey)+arbitraryEd25519Pair = do+ bytes <- vectorOf 32 arbitrary+ let CryptoPassed priv = Ed25519.secretKey (B.pack bytes)+ return (Ed25519.toPublic priv, priv)++arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey)+arbitraryEd448Pair = do+ bytes <- vectorOf 57 arbitrary+ let CryptoPassed priv = Ed448.secretKey (B.pack bytes)+ return (Ed448.toPublic priv, priv)
Tests/Tests.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} import Test.Tasty@@ -9,8 +8,11 @@ import Connection import Marshalling import Ciphers+import PubKey +import Data.Foldable (traverse_) import Data.Maybe+import Data.Default.Class import Data.List (intersect) import qualified Data.ByteString as B@@ -20,9 +22,11 @@ import Network.TLS.Extra import Control.Applicative import Control.Concurrent+import Control.Concurrent.Async import Control.Monad import Data.IORef+import Data.X509 (ExtKeyUsageFlag(..)) import System.Timeout @@ -45,76 +49,404 @@ return () -recvDataNonNull :: Context -> IO C8.ByteString-recvDataNonNull ctx = recvData ctx >>= \l -> if B.null l then recvDataNonNull ctx else return l+chunkLengths :: Int -> [Int]+chunkLengths len+ | len > 16384 = 16384 : chunkLengths (len - 16384)+ | len > 0 = [len]+ | otherwise = [] -runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan C8.ByteString -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()-runTLSPipe params tlsServer tlsClient = do- (startQueue, resultQueue) <- run (establishDataPipe params tlsServer tlsClient)+runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()+runTLSPipeN n params tlsServer tlsClient = do+ (writeStart, readResult) <- run (establishDataPipe params tlsServer tlsClient) -- send some data- d <- B.pack <$> pick (someWords8 256)- run $ writeChan startQueue d+ ds <- replicateM n $ do+ d <- B.pack <$> pick (someWords8 256)+ _ <- run $ writeStart d+ return d -- receive it- dres <- run $ timeout 10000000 $ readChan resultQueue+ dsres <- run $ timeout 60000000 readResult -- 60 sec -- check if it equal- Just d `assertEq` dres- return ()+ Just ds `assertEq` dsres +runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO ()+runTLSPipe = runTLSPipeN 1++runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO ()+runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient+ where tlsServer ctx queue = do+ handshake ctx+ checkInfoPredicate ctx+ d <- recvData ctx+ writeChan queue [d]+ bye ctx+ tlsClient queue ctx = do+ handshake 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 = runTLSPipe params tlsServer tlsClient+runTLSPipeSimple params = runTLSPipePredicate params (const True)++runTLSPipeSimple13 :: (ClientParams, ServerParams) -> HandshakeMode13 -> Maybe C8.ByteString -> PropertyM IO ()+runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx- d <- recvDataNonNull ctx- writeChan queue d- return ()+ 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+ writeChan queue [d]+ minfo <- contextGetInformation ctx+ Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode)+ bye ctx tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d])+ minfo <- contextGetInformation ctx+ Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode)+ byeBye ctx++runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO ()+runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient+ where tlsServer ctx queue = do+ handshake ctx+ d0 <- recvData ctx+ req <- generate $ elements [OneWay, TwoWay]+ _ <- updateKey ctx req+ d1 <- recvData ctx+ d2 <- recvData ctx+ writeChan queue [d0,d1,d2] bye ctx- return ()+ tlsClient queue ctx = do+ handshake ctx+ d0 <- readChan queue+ sendData ctx (L.fromChunks [d0])+ d1 <- readChan queue+ sendData ctx (L.fromChunks [d1])+ req <- generate $ elements [OneWay, TwoWay]+ _ <- updateKey ctx req+ d2 <- readChan queue+ sendData ctx (L.fromChunks [d2])+ byeBye ctx -runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO ()-runTLSInitFailure params = do+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 = handshake ctx >> bye ctx >> return ("server success" :: String)- tlsClient ctx = handshake ctx >> bye ctx >> return ("client success" :: String)+ where tlsServer ctx = do+ _ <- hsServer ctx+ minfo <- contextGetInformation ctx+ byeBye ctx+ return $ "server success: " ++ show minfo+ tlsClient ctx = do+ _ <- hsClient ctx+ minfo <- contextGetInformation ctx+ byeBye ctx+ return $ "client success: " ++ show minfo +runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO ()+runTLSInitFailure params = runTLSInitFailureGen params handshake handshake+ prop_handshake_initiate :: PropertyM IO () prop_handshake_initiate = do params <- pick arbitraryPairParams runTLSPipeSimple params +prop_handshake13_initiate :: PropertyM IO ()+prop_handshake13_initiate = do+ params <- pick arbitraryPairParams13+ let cgrps = supportedGroups $ clientSupported $ fst params+ sgrps = supportedGroups $ serverSupported $ snd params+ hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest+ runTLSPipeSimple13 params hs Nothing++prop_handshake_keyupdate :: PropertyM IO ()+prop_handshake_keyupdate = do+ params <- pick arbitraryPairParams+ runTLSPipeSimpleKeyUpdate params++prop_handshake13_downgrade :: PropertyM IO ()+prop_handshake13_downgrade = do+ (cparam,sparam) <- pick arbitraryPairParams+ versionForced <- pick $ elements (supportedVersions $ clientSupported cparam)+ let debug' = (serverDebug sparam) { debugVersionForced = Just versionForced }+ sparam' = sparam { serverDebug = debug' }+ params = (cparam,sparam')+ downgraded = (isVersionEnabled TLS13 params && versionForced < TLS13) ||+ (isVersionEnabled TLS12 params && versionForced < TLS12)+ if downgraded+ then runTLSInitFailure params+ else runTLSPipeSimple params++prop_handshake13_full :: PropertyM IO ()+prop_handshake13_full = do+ (cli, srv) <- pick arbitraryPairParams13+ let cliSupported = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported = def {+ supportedVersions = [TLS13]+ , 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 {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [P256,X25519]+ }+ svrSupported = def {+ supportedVersions = [TLS13]+ , 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 {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [P256,X25519]+ }+ svrSupported = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported }+ )++ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSPipeSimple13 params HelloRetryRequest Nothing++ -- and resume+ sessionParams <- run $ readClientSessionRef sessionRefs+ assert (isJust sessionParams)+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++ runTLSPipeSimple13 params2 PreSharedKey Nothing++prop_handshake13_psk_fallback :: PropertyM IO ()+prop_handshake13_psk_fallback = do+ (cli, srv) <- pick arbitraryPairParams13+ let cliSupported = def+ { supportedVersions = [TLS13]+ , supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES128CCM_SHA256+ ]+ , supportedGroups = [P256,X25519]+ }+ svrSupported = def+ { supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported }+ )++ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSPipeSimple13 params HelloRetryRequest Nothing++ -- resumption fails because GCM cipher is not supported anymore, full+ -- handshake is not possible because X25519 has been removed, so we are+ -- back with P256 after hello retry+ sessionParams <- run $ readClientSessionRef sessionRefs+ assert (isJust sessionParams)+ let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params+ srv2' = srv2 { serverSupported = svrSupported' }+ svrSupported' = def+ { supportedVersions = [TLS13]+ , 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 {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [P256,X25519]+ }+ svrSupported = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported+ , serverEarlyDataSize = 2048 }+ )++ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ runTLSPipeSimple13 params HelloRetryRequest Nothing++ -- and resume+ sessionParams <- run $ readClientSessionRef sessionRefs+ assert (isJust sessionParams)+ earlyData <- B.pack <$> pick (someWords8 256)+ let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ params2 = (pc { clientEarlyData = Just earlyData } , ps)++ runTLSPipeSimple13 params2 RTT0 (Just earlyData)++prop_handshake13_rtt0_fallback :: PropertyM IO ()+prop_handshake13_rtt0_fallback = do+ ticketSize <- pick $ choose (0, 512)+ (cli, srv) <- pick arbitraryPairParams13+ group0 <- pick $ elements [P256,X25519]+ let cliSupported = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [P256,X25519]+ }+ svrSupported = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [group0]+ }+ params0 = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported+ , serverEarlyDataSize = ticketSize }+ )++ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs++ let params = setPairParamsSessionManagers sessionManagers params0++ let mode = if group0 == P256 then FullHandshake else HelloRetryRequest+ runTLSPipeSimple13 params mode Nothing++ -- and resume+ sessionParams <- run $ readClientSessionRef sessionRefs+ assert (isJust sessionParams)+ earlyData <- B.pack <$> pick (someWords8 256)+ group2 <- pick $ elements [P256,X25519]+ let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ svrSupported2 = def {+ supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [group2]+ }+ params2 = (pc { clientEarlyData = Just earlyData }+ ,ps { serverEarlyDataSize = 0+ , serverSupported = svrSupported2+ }+ )++ let mode2 = if ticketSize < 256 then PreSharedKey else RTT0+ runTLSPipeSimple13 params2 mode2 Nothing++prop_handshake13_rtt0_length :: PropertyM IO ()+prop_handshake13_rtt0_length = do+ serverMax <- pick $ choose (0, 33792)+ (cli, srv) <- pick arbitraryPairParams13+ let cliSupported = def+ { supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ svrSupported = def+ { supportedVersions = [TLS13]+ , supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]+ , supportedGroups = [X25519]+ }+ params0 = (cli { clientSupported = cliSupported }+ ,srv { serverSupported = svrSupported+ , serverEarlyDataSize = serverMax }+ )++ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ let params = setPairParamsSessionManagers sessionManagers params0+ runTLSPipeSimple13 params FullHandshake Nothing++ -- and resume+ sessionParams <- run $ readClientSessionRef sessionRefs+ assert (isJust sessionParams)+ clientLen <- pick $ choose (0, 33792)+ earlyData <- B.pack <$> pick (someWords8 clientLen)+ let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params+ params2 = (pc { clientEarlyData = Just earlyData } , ps)+ (mode, mEarlyData)+ | clientLen > serverMax = (PreSharedKey, Nothing)+ | otherwise = (RTT0, Just earlyData)+ runTLSPipeSimple13 params2 mode mEarlyData+ prop_handshake_ciphersuites :: PropertyM IO () prop_handshake_ciphersuites = do- let clientVersions = [TLS12]- serverVersions = [TLS12]+ tls13 <- pick arbitrary+ let version = if tls13 then TLS13 else TLS12 clientCiphers <- pick arbitraryCiphers serverCiphers <- pick arbitraryCiphers (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers- (clientVersions, serverVersions)+ ([version], [version]) (clientCiphers, serverCiphers)- let shouldFail = null (clientCiphers `intersect` serverCiphers)- if shouldFail- then runTLSInitFailure (clientParam,serverParam)- else runTLSPipeSimple (clientParam,serverParam)+ let adequate = cipherAllowedForVersion version+ shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers)+ if shouldSucceed+ then runTLSPipeSimple (clientParam,serverParam)+ else runTLSInitFailure (clientParam,serverParam) prop_handshake_hashsignatures :: PropertyM IO () prop_handshake_hashsignatures = do- let clientVersions = [TLS12]- serverVersions = [TLS12]+ 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- (clientVersions, serverVersions)+ ([version], [version]) (ciphers, ciphers)- clientHashSigs <- pick arbitraryHashSignatures- serverHashSigs <- pick arbitraryHashSignatures+ clientHashSigs <- pick $ arbitraryHashSignatures version+ serverHashSigs <- pick $ arbitraryHashSignatures version let clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedHashSignatures = clientHashSigs } }@@ -159,22 +491,62 @@ runTLSPipeSimple (clientParam',serverParam) serverChain <- run $ readIORef chainRef dssDisallowed `assertEq` isLeafRSA serverChain- where- isLeafRSA chain = case chain >>= leafPublicKey of- Just (PubKeyRSA _) -> True- _ -> False +-- Same as above but testing with supportedHashSignatures directly instead of+-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the+-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by+-- both client and server, the Ed25519 certificate is selected. Otherwise the+-- server fallbacks to RSA.+--+-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13+-- unless client advertises explicit support. Currently this is not enforced by+-- the library, which is useful to test this scenario. SHA-1 could be replaced+-- by another algorithm.+prop_handshake_cert_fallback_hs :: PropertyM IO ()+prop_handshake_cert_fallback_hs = do+ tls13 <- pick arbitrary+ let versions = if tls13 then [TLS13] else [TLS12]+ ciphers = [ cipher_ECDHE_RSA_AES128GCM_SHA256+ , cipher_ECDHE_ECDSA_AES128GCM_SHA256+ , cipher_TLS13_AES128GCM_SHA256+ ]+ commonHS = [ (HashSHA256, SignatureRSA)+ , (HashIntrinsic, SignatureRSApssRSAeSHA256)+ ]+ otherHS = [ (HashIntrinsic, SignatureEd25519) ]+ chainRef <- run $ newIORef Nothing+ clientHS <- pick $ sublistOf otherHS+ serverHS <- pick $ sublistOf otherHS+ (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers+ (versions, versions)+ (ciphers, ciphers)+ let clientParam' = clientParam { clientSupported = (clientSupported clientParam)+ { supportedHashSignatures = commonHS ++ clientHS }+ , clientHooks = (clientHooks clientParam)+ { onServerCertificate = \_ _ _ chain ->+ writeIORef chainRef (Just chain) >> return [] }+ }+ serverParam' = serverParam { serverSupported = (serverSupported serverParam)+ { supportedHashSignatures = commonHS ++ serverHS }+ }+ eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS+ || (HashIntrinsic, SignatureEd25519) `notElem` serverHS+ runTLSPipeSimple (clientParam',serverParam')+ serverChain <- run $ readIORef chainRef+ eddsaDisallowed `assertEq` isLeafRSA serverChain+ prop_handshake_groups :: PropertyM IO () prop_handshake_groups = do- let clientVersions = [TLS12]- serverVersions = [TLS12]+ 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- (clientVersions, serverVersions)+ (versions, versions) (ciphers, ciphers) clientGroups <- pick arbitraryGroups serverGroups <- pick arbitraryGroups@@ -189,15 +561,67 @@ { supportedGroups = serverGroups } } isCustom = maybe True isCustomDHParams (serverDHEParams serverParam')- shouldFail = null (clientGroups `intersect` serverGroups) && isCustom && denyCustom+ mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup+ isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup+ commonGroups = clientGroups `intersect` serverGroups+ shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom)+ p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom) if shouldFail then runTLSInitFailure (clientParam',serverParam')- else runTLSPipeSimple (clientParam',serverParam')+ else runTLSPipePredicate (clientParam',serverParam') p ++prop_handshake_dh :: PropertyM IO ()+prop_handshake_dh = do+ let clientVersions = [TLS12]+ serverVersions = [TLS12]+ ciphers = [ cipher_DHE_RSA_AES128_SHA1 ]+ (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers+ (clientVersions, serverVersions)+ (ciphers, ciphers)+ let clientParam' = clientParam { clientSupported = (clientSupported clientParam)+ { supportedGroups = [] }+ }+ let check (dh,shouldFail) = do+ let serverParam' = serverParam { serverDHEParams = Just dh }+ if shouldFail+ then runTLSInitFailure (clientParam',serverParam')+ else runTLSPipeSimple (clientParam',serverParam')+ mapM_ check [(dhParams512,True)+ ,(dhParams768,True)+ ,(dhParams1024,False)]++prop_handshake_srv_key_usage :: PropertyM IO ()+prop_handshake_srv_key_usage = do+ tls13 <- pick arbitrary+ let versions = if tls13 then [TLS13] else [SSL3,TLS10,TLS11,TLS12]+ ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_DHE_RSA_AES128_SHA1+ , cipher_AES256_SHA256+ ]+ (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers+ (versions, versions)+ (ciphers, ciphers)+ usageFlags <- pick arbitraryKeyUsage+ cred <- pick $ arbitraryRSACredentialWithUsage usageFlags+ let serverParam' = serverParam+ { serverShared = (serverShared serverParam)+ { sharedCredentials = Credentials [cred]+ }+ }+ hasDS = KeyUsage_digitalSignature `elem` usageFlags+ hasKE = KeyUsage_keyEncipherment `elem` usageFlags+ shouldSucceed = hasDS || (hasKE && not tls13)+ if shouldSucceed+ then runTLSPipeSimple (clientParam,serverParam')+ else runTLSInitFailure (clientParam,serverParam')+ prop_handshake_client_auth :: PropertyM IO () prop_handshake_client_auth = do (clientParam,serverParam) <- pick arbitraryPairParams- cred <- pick arbitraryClientCredential+ let version = maximum (supportedVersions $ serverSupported serverParam)+ cred <- pick (arbitraryClientCredential version) let clientParam' = clientParam { clientHooks = (clientHooks clientParam) { onCertificateRequest = \_ -> return $ Just cred } }@@ -205,11 +629,31 @@ , serverHooks = (serverHooks serverParam) { onClientCertificate = validateChain cred } }- runTLSPipeSimple (clientParam',serverParam')+ let shouldFail = version == TLS13 && isCredentialDSA cred+ if shouldFail+ then runTLSInitFailure (clientParam',serverParam')+ else runTLSPipeSimple (clientParam',serverParam') where validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) +prop_handshake_clt_key_usage :: PropertyM IO ()+prop_handshake_clt_key_usage = do+ (clientParam,serverParam) <- pick arbitraryPairParams+ usageFlags <- pick arbitraryKeyUsage+ cred <- pick $ arbitraryRSACredentialWithUsage usageFlags+ let clientParam' = clientParam { clientHooks = (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred }+ }+ serverParam' = serverParam { serverWantClientCert = True+ , serverHooks = (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept }+ }+ shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags+ if shouldSucceed+ then runTLSPipeSimple (clientParam',serverParam')+ else runTLSInitFailure (clientParam',serverParam')+ prop_handshake_alpn :: PropertyM IO () prop_handshake_alpn = do (clientParam,serverParam) <- pick arbitraryPairParams@@ -225,17 +669,16 @@ handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto- d <- recvDataNonNull ctx- writeChan queue d- return ()+ d <- recvData ctx+ writeChan queue [d]+ bye ctx tlsClient queue ctx = do handshake ctx proto <- getNegotiatedProtocol ctx Just "h2" `assertEq` proto d <- readChan queue sendData ctx (L.fromChunks [d])- bye ctx- return ()+ byeBye ctx alpn xs | "h2" `elem` xs = return "h2" | otherwise = return "http/1.1"@@ -252,61 +695,86 @@ handshake ctx sni <- getClientSNI ctx Just serverName `assertEq` sni- d <- recvDataNonNull ctx- writeChan queue d- return ()+ d <- recvData ctx+ writeChan queue [d]+ bye ctx tlsClient queue ctx = do handshake ctx d <- readChan queue sendData ctx (L.fromChunks [d])- bye ctx- return ()+ byeBye ctx 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 = True+ supportedClientInitiatedRenegotiation = not renegDisabled } }- runTLSPipe (cparams, sparams') tlsServer tlsClient+ if renegDisabled || isVersionEnabled TLS13 (cparams, sparams')+ then runTLSInitFailureGen (cparams, sparams') hsServer hsClient+ else runTLSPipe (cparams, sparams') tlsServer tlsClient where tlsServer ctx queue = do- handshake ctx- d <- recvDataNonNull ctx- writeChan queue d- return ()+ hsServer ctx+ d <- recvData ctx+ writeChan queue [d]+ bye ctx tlsClient queue ctx = do- handshake ctx- handshake ctx+ hsClient ctx d <- readChan queue sendData ctx (L.fromChunks [d])- bye ctx- return ()+ byeBye ctx+ hsServer = handshake+ hsClient ctx = handshake ctx >> handshake ctx prop_handshake_session_resumption :: PropertyM IO () prop_handshake_session_resumption = do- sessionRef <- run $ newIORef Nothing- let sessionManager = oneSessionManager sessionRef+ sessionRefs <- run twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs plainParams <- pick arbitraryPairParams- let params = setPairParamsSessionManager sessionManager plainParams+ let params = setPairParamsSessionManagers sessionManagers plainParams runTLSPipeSimple params -- and resume- sessionParams <- run $ readIORef sessionRef+ sessionParams <- run $ readClientSessionRef sessionRefs assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipeSimple params2 +prop_thread_safety :: PropertyM IO ()+prop_thread_safety = do+ params <- pick arbitraryPairParams+ runTLSPipe params tlsServer tlsClient+ where tlsServer ctx queue = do+ handshake ctx+ runReaderWriters ctx "client-value" "server-value"+ d <- recvData ctx+ writeChan queue [d]+ bye ctx+ tlsClient queue ctx = do+ handshake 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 [reader ctx r, writer ctx w]+ in runConcurrently $ traverse_ Concurrently workers+ writer = sendData+ reader ctx val = do { bs <- recvData ctx; val `assertEq` bs }+ assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) assertIsLeft :: (Show b, Monad m) => Either a b -> m ()-assertIsLeft (Left _) = return()+assertIsLeft (Left _) = return () assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") main :: IO ()@@ -314,6 +782,7 @@ [ tests_marshalling , tests_ciphers , tests_handshake+ , tests_thread_safety ] where -- lowlevel tests to check the packet marshalling. tests_marshalling = testGroup "Marshalling"@@ -327,13 +796,31 @@ tests_handshake = testGroup "Handshakes" [ testProperty "Setup" (monadicIO prop_pipe_work) , testProperty "Initiation" (monadicIO prop_handshake_initiate)+ , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate)+ , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate)+ , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) , testProperty "Groups" (monadicIO prop_handshake_groups)- , testProperty "Certificate fallback" (monadicIO prop_handshake_cert_fallback)+ , 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 "ALPN" (monadicIO prop_handshake_alpn) , testProperty "SNI" (monadicIO prop_handshake_sni) , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) , testProperty "Resumption" (monadicIO prop_handshake_session_resumption)+ , testProperty "Custom DH" (monadicIO prop_handshake_dh)+ , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full)+ , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr)+ , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk)+ , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback)+ , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0)+ , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback)+ , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) ]++ -- test concurrent reads and writes+ tests_thread_safety = localOption (QuickCheckTests 10) $+ testProperty "Thread safety" (monadicIO prop_thread_safety)
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.4.1+Version: 1.5.0 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -7,7 +7,7 @@ eliminating a common set of security issues through the use of the advanced type system, high level constructions and common Haskell features. .- Currently implement the SSL3.0, TLS1.0, TLS1.1 and TLS1.2 protocol,+ Currently implement the SSL3.0, TLS1.0, TLS1.1, TLS1.2 and TLS 1.3 protocol, and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges, and many extensions. .@@ -40,22 +40,23 @@ Default: False Library- Build-Depends: base >= 4.7 && < 5+ Build-Depends: base >= 4.9 && < 5 , mtl >= 2 , transformers- , cereal >= 0.4+ , cereal >= 0.5.3 , bytestring , data-default-class -- crypto related , memory >= 0.14.6- , cryptonite >= 0.24+ , cryptonite >= 0.25 -- certificate related , asn1-types >= 0.2.0 , asn1-encoding- , x509 >= 1.7.1+ , x509 >= 1.7.5 , x509-store >= 1.6 , x509-validation >= 1.6.5 , async >= 2.0+ , hourglass if flag(network) Build-Depends: network >= 2.4.0.0 cpp-options: -DINCLUDE_NETWORK@@ -71,6 +72,7 @@ Network.TLS.Extra.FFDHE other-modules: Network.TLS.Cap Network.TLS.Struct+ Network.TLS.Struct13 Network.TLS.Core Network.TLS.Context Network.TLS.Context.Internal@@ -84,30 +86,40 @@ Network.TLS.Extension Network.TLS.Handshake Network.TLS.Handshake.Common+ Network.TLS.Handshake.Common13 Network.TLS.Handshake.Certificate Network.TLS.Handshake.Key Network.TLS.Handshake.Client Network.TLS.Handshake.Server Network.TLS.Handshake.Process+ Network.TLS.Handshake.Random Network.TLS.Handshake.Signature Network.TLS.Handshake.State+ Network.TLS.Handshake.State13 Network.TLS.Hooks Network.TLS.IO Network.TLS.Imports+ Network.TLS.KeySchedule Network.TLS.MAC Network.TLS.Measurement Network.TLS.Packet+ Network.TLS.Packet13 Network.TLS.Parameters Network.TLS.Record Network.TLS.Record.Types+ Network.TLS.Record.Types13 Network.TLS.Record.Engage+ Network.TLS.Record.Engage13 Network.TLS.Record.Disengage+ Network.TLS.Record.Disengage13 Network.TLS.Record.State Network.TLS.RNG Network.TLS.State Network.TLS.Session Network.TLS.Sending+ Network.TLS.Sending13 Network.TLS.Receiving+ Network.TLS.Receiving13 Network.TLS.Util Network.TLS.Util.ASN1 Network.TLS.Util.Serialization@@ -129,8 +141,7 @@ PipeChan PubKey Build-Depends: base >= 3 && < 5- , mtl- , cereal >= 0.3+ , async >= 2.0 , data-default-class , tasty , tasty-quickcheck@@ -148,16 +159,20 @@ hs-source-dirs: Benchmarks Tests Main-Is: Benchmarks.hs type: exitcode-stdio-1.0+ other-modules: Certificate+ Connection+ PipeChan+ PubKey Build-depends: base >= 4 && < 5 , tls , x509 , x509-validation , data-default-class , cryptonite- , criterion >= 1.0- , mtl+ , gauge , bytestring , asn1-types+ , async >= 2.0 , hourglass , QuickCheck >= 2 , tasty-quickcheck