tls 1.3.9 → 1.3.10
raw patch · 21 files changed
+512/−159 lines, 21 filesdep ~asyncdep ~basedep ~bytestring
Dependency ranges changed: async, base, bytestring, cereal, data-default-class, hans, mtl, network, transformers, x509, x509-validation
Files
- Network/TLS/Backend.hs +2/−2
- Network/TLS/Cipher.hs +1/−2
- Network/TLS/Core.hs +2/−2
- Network/TLS/Credentials.hs +8/−8
- Network/TLS/Extra.hs +2/−0
- Network/TLS/Extra/Cipher.hs +6/−7
- Network/TLS/Extra/FFDHE.hs +62/−0
- Network/TLS/Handshake/Client.hs +23/−8
- Network/TLS/Handshake/Common.hs +1/−1
- Network/TLS/Handshake/Process.hs +8/−10
- Network/TLS/Handshake/Server.hs +146/−35
- Network/TLS/Handshake/Signature.hs +56/−44
- Network/TLS/Handshake/State.hs +24/−0
- Network/TLS/IO.hs +0/−1
- Network/TLS/Packet.hs +12/−0
- Network/TLS/Parameters.hs +14/−4
- Network/TLS/Record/State.hs +0/−1
- Network/TLS/Wire.hs +5/−0
- Tests/Connection.hs +66/−14
- Tests/Tests.hs +70/−17
- tls.cabal +4/−3
Network/TLS/Backend.hs view
@@ -27,7 +27,7 @@ #ifdef INCLUDE_NETWORK import Control.Monad-import qualified Network.Socket as Network (Socket, sClose)+import qualified Network.Socket as Network (Socket, close) import qualified Network.Socket.ByteString as Network #endif @@ -72,7 +72,7 @@ #ifdef INCLUDE_NETWORK instance HasBackend Network.Socket where initializeBackend _ = return ()- getBackend sock = Backend (return ()) (Network.sClose sock) (Network.sendAll sock) recvAll+ getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll where recvAll n = B.concat `fmap` loop n where loop 0 = return [] loop left = do
Network/TLS/Cipher.hs view
@@ -32,8 +32,7 @@ ) where import Crypto.Cipher.Types (AuthTag)-import Network.TLS.Types (CipherID)-import Network.TLS.Struct (Version(..))+import Network.TLS.Types (CipherID, Version(..)) import Network.TLS.Crypto (Hash(..), hashDigestSize) import qualified Data.ByteString as B
Network/TLS/Core.hs view
@@ -88,10 +88,10 @@ where doRecv = do pkt <- withReadLock ctx $ recvPacket ctx either onError process pkt- + safeHandleError_EOF Error_EOF = Just () safeHandleError_EOF _ = Nothing- + onError err@(Error_Protocol (reason,fatal,desc)) = terminate err (if fatal then AlertLevel_Fatal else AlertLevel_Warning) desc reason onError err =
Network/TLS/Credentials.hs view
@@ -95,14 +95,14 @@ -- this change in future. credentialCanDecrypt :: Credential -> Maybe () credentialCanDecrypt (chain, priv) =- case extensionGet (certExtensions cert) of- Nothing -> Just ()- Just (ExtKeyUsage flags)- | KeyUsage_keyEncipherment `elem` flags ->- case (pub, priv) of- (PubKeyRSA _, PrivKeyRSA _) -> Just ()- _ -> Nothing- | otherwise -> Nothing+ case (pub, priv) of+ (PubKeyRSA _, PrivKeyRSA _) ->+ case extensionGet (certExtensions cert) of+ Nothing -> Just ()+ Just (ExtKeyUsage flags)+ | KeyUsage_keyEncipherment `elem` flags -> Just ()+ | otherwise -> Nothing+ _ -> Nothing where cert = signedObject $ getSigned signed pub = certPubKey cert signed = getCertificateChainLeaf chain
Network/TLS/Extra.hs view
@@ -8,6 +8,8 @@ -- default values and ciphers module Network.TLS.Extra ( module Network.TLS.Extra.Cipher+ , module Network.TLS.Extra.FFDHE ) where import Network.TLS.Extra.Cipher+import Network.TLS.Extra.FFDHE
Network/TLS/Extra/Cipher.hs view
@@ -6,7 +6,6 @@ -- Portability : unknown -- {-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-} module Network.TLS.Extra.Cipher ( -- * cipher suite@@ -55,7 +54,7 @@ import qualified Data.ByteString as B -import Network.TLS (Version(..))+import Network.TLS.Types (Version(..)) import Network.TLS.Cipher import Data.Tuple (swap) @@ -189,9 +188,9 @@ , cipher_AES128_SHA1 ] --- | The strongest ciphers supported 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.+-- | 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. ciphersuite_strong :: [Cipher] ciphersuite_strong = [ -- If we have PFS + AEAD + SHA2, then allow AES128, else just 256@@ -527,7 +526,7 @@ , cipherBulk = bulk_aes128 , cipherHash = SHA1 , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 } @@ -538,7 +537,7 @@ , cipherBulk = bulk_aes256 , cipherHash = SHA1 , cipherPRFHash = Nothing- , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA , cipherMinVer = Just TLS10 }
+ Network/TLS/Extra/FFDHE.hs view
@@ -0,0 +1,62 @@+-- |+-- Module : Network.TLS.Extra+-- License : BSD-style+-- Maintainer : Kazu Yamamoto <kazu@iij.ad.jp>+-- Stability : experimental+-- Portability : unknown+--+-- Finite Field Diffie-Hellman Ephemeral Parameters defined in RFC 7919.+module Network.TLS.Extra.FFDHE where++import Crypto.PubKey.DH+import Network.TLS.Crypto.DH (DHParams)++-- | 2048 bits finite field Diffie-Hellman ephemeral parameters+-- defined in RFC 7919.+-- The estimated symmetric-equivalent strength is 103 bits.+ffdhe2048 :: DHParams+ffdhe2048 = Params {+ params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B423861285C97FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 2048+ }++-- | 3072 bits finite field Diffie-Hellman ephemeral parameters+-- defined in RFC 7919.+-- The estimated symmetric-equivalent strength is 125 bits.+ffdhe3072 :: DHParams+ffdhe3072 = Params {+ params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B66C62E37FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 3072+ }++-- | 4096 bits finite field Diffie-Hellman ephemeral parameters+-- defined in RFC 7919.+-- The estimated symmetric-equivalent strength is 150 bits.+ffdhe4096 :: DHParams+ffdhe4096 = Params {+ params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E655F6AFFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 4096+ }++-- | 6144 bits finite field Diffie-Hellman ephemeral parameters+-- defined in RFC 7919.+-- The estimated symmetric-equivalent strength is 175 bits.+ffdhe6144 :: DHParams+ffdhe6144 = Params {+ params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CD0E40E65FFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 6144+ }++-- | 8192 bits finite field Diffie-Hellman ephemeral parameters+-- defined in RFC 7919.+-- The estimated symmetric-equivalent strength is 192 bits.+ffdhe8192 :: DHParams+ffdhe8192 = Params {+ params_p = 0xFFFFFFFFFFFFFFFFADF85458A2BB4A9AAFDC5620273D3CF1D8B9C583CE2D3695A9E13641146433FBCC939DCE249B3EF97D2FE363630C75D8F681B202AEC4617AD3DF1ED5D5FD65612433F51F5F066ED0856365553DED1AF3B557135E7F57C935984F0C70E0E68B77E2A689DAF3EFE8721DF158A136ADE73530ACCA4F483A797ABC0AB182B324FB61D108A94BB2C8E3FBB96ADAB760D7F4681D4F42A3DE394DF4AE56EDE76372BB190B07A7C8EE0A6D709E02FCE1CDF7E2ECC03404CD28342F619172FE9CE98583FF8E4F1232EEF28183C3FE3B1B4C6FAD733BB5FCBC2EC22005C58EF1837D1683B2C6F34A26C1B2EFFA886B4238611FCFDCDE355B3B6519035BBC34F4DEF99C023861B46FC9D6E6C9077AD91D2691F7F7EE598CB0FAC186D91CAEFE130985139270B4130C93BC437944F4FD4452E2D74DD364F2E21E71F54BFF5CAE82AB9C9DF69EE86D2BC522363A0DABC521979B0DEADA1DBF9A42D5C4484E0ABCD06BFA53DDEF3C1B20EE3FD59D7C25E41D2B669E1EF16E6F52C3164DF4FB7930E9E4E58857B6AC7D5F42D69F6D187763CF1D5503400487F55BA57E31CC7A7135C886EFB4318AED6A1E012D9E6832A907600A918130C46DC778F971AD0038092999A333CB8B7A1A1DB93D7140003C2A4ECEA9F98D0ACC0A8291CDCEC97DCF8EC9B55A7F88A46B4DB5A851F44182E1C68A007E5E0DD9020BFD64B645036C7A4E677D2C38532A3A23BA4442CAF53EA63BB454329B7624C8917BDD64B1C0FD4CB38E8C334C701C3ACDAD0657FCCFEC719B1F5C3E4E46041F388147FB4CFDB477A52471F7A9A96910B855322EDB6340D8A00EF092350511E30ABEC1FFF9E3A26E7FB29F8C183023C3587E38DA0077D9B4763E4E4B94B2BBC194C6651E77CAF992EEAAC0232A281BF6B3A739C1226116820AE8DB5847A67CBEF9C9091B462D538CD72B03746AE77F5E62292C311562A846505DC82DB854338AE49F5235C95B91178CCF2DD5CACEF403EC9D1810C6272B045B3B71F9DC6B80D63FDD4A8E9ADB1E6962A69526D43161C1A41D570D7938DAD4A40E329CCFF46AAA36AD004CF600C8381E425A31D951AE64FDB23FCEC9509D43687FEB69EDD1CC5E0B8CC3BDF64B10EF86B63142A3AB8829555B2F747C932665CB2C0F1CC01BD70229388839D2AF05E454504AC78B7582822846C0BA35C35F5C59160CC046FD8251541FC68C9C86B022BB7099876A460E7451A8A93109703FEE1C217E6C3826E52C51AA691E0E423CFC99E9E31650C1217B624816CDAD9A95F9D5B8019488D9C0A0A1FE3075A577E23183F81D4A3F2FA4571EFC8CE0BA8A4FE8B6855DFE72B0A66EDED2FBABFBE58A30FAFABE1C5D71A87E2F741EF8C1FE86FEA6BBFDE530677F0D97D11D49F7A8443D0822E506A9F4614E011E2A94838FF88CD68C8BB7C5C6424CFFFFFFFFFFFFFFFF+ , params_g = 2+ , params_bits = 8192+ }
Network/TLS/Handshake/Client.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style@@ -174,6 +174,7 @@ 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@@ -205,7 +206,7 @@ sendPacket ctx $ Handshake [ClientKeyXchg ckx] where getCKX_DHE = do xver <- usingState_ ctx getVersion- serverParams <- fromJust <$> usingHState ctx (gets hstServerDHParams)+ serverParams <- usingHState ctx getServerDHParams (clientDHPriv, clientDHPub) <- generateDHE ctx (serverDHParamsToParams serverParams) let premaster = dhGetShared (serverDHParamsToParams serverParams)@@ -217,7 +218,7 @@ getCKX_ECDHE = do xver <- usingState_ ctx getVersion- (ServerECDHParams ecdhparams serverECDHPub) <- fromJust <$> usingHState ctx (gets hstServerECDHParams)+ (ServerECDHParams ecdhparams serverECDHPub) <- usingHState ctx getServerECDHParams (clientECDHPriv, clientECDHPub) <- generateECDHE ctx ecdhparams case ecdhGetShared ecdhparams clientECDHPriv serverECDHPub of@@ -244,23 +245,37 @@ certSent <- usingHState ctx $ getClientCertSent case certSent of True -> do- malg <- case usedVersion of+ sigAlg <- getLocalSignatureAlg++ mhash <- 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- hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs+ matchHashSigs = filter (\ a -> snd a == sigAlg) suppHashSigs+ hashSigs' = filter (\ a -> a `elem` hashSigs) matchHashSigs when (null hashSigs') $- throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure)- return $ Just $ head hashSigs'+ throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure)+ return $ Just $ fst $ head hashSigs' _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages- sigDig <- certificateVerifyCreate ctx usedVersion malg msgs+ sigDig <- certificateVerifyCreate ctx usedVersion sigAlg mhash msgs sendPacket ctx $ Handshake [CertVerify sigDig] _ -> return ()++ getLocalSignatureAlg = do+ pk <- usingHState ctx getLocalPrivateKey+ case pk of+ PrivKeyRSA _ -> return SignatureRSA+ PrivKeyDSA _ -> return SignatureDSS+ _ -> throwCore $ Error_Protocol ("unsupported local private key type", True, HandshakeFailure) processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw 0xff01 content) = do
Network/TLS/Handshake/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Network.TLS.Handshake.Common ( handshakeFailed , errorToAlert
Network/TLS/Handshake/Process.hs view
@@ -95,8 +95,8 @@ rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext - serverParams <- fromJust "server dh params" <$> usingHState ctx (gets hstServerDHParams)- dhpriv <- fromJust "dh private" <$> usingHState ctx (gets hstDHPrivate)+ serverParams <- usingHState ctx getServerDHParams+ dhpriv <- usingHState ctx getDHPrivate let premaster = dhGetShared (serverDHParamsToParams serverParams) dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster @@ -104,8 +104,8 @@ rver <- usingState_ ctx getVersion role <- usingState_ ctx isClientContext - (ServerECDHParams ecdhparams _) <- fromJust "server ecdh params" <$> usingHState ctx (gets hstServerECDHParams)- ecdhpriv <- fromJust "ecdh private" <$> usingHState ctx (gets hstECDHPrivate)+ (ServerECDHParams ecdhparams _) <- usingHState ctx getServerECDHParams+ ecdhpriv <- usingHState ctx getECDHPrivate case ecdhGetShared ecdhparams ecdhpriv clientECDHValue of Nothing -> throwCore $ Error_Protocol("invalid client public key", True, HandshakeFailure) Just premaster ->@@ -120,10 +120,8 @@ usingState_ ctx $ updateVerifiedData ServerRole fdata return () +-- initialize a new Handshake context (initial handshake or renegotiations) startHandshake :: Context -> Version -> ClientRandom -> IO ()-startHandshake ctx ver crand = do- -- FIXME check if handshake is already not null- liftIO $ modifyMVar_ (ctxHandshake ctx) $ \hs ->- case hs of- Nothing -> return $ Just $ newEmptyHandshake ver crand- Just _ -> return hs+startHandshake ctx ver crand =+ let hs = Just $ newEmptyHandshake ver crand+ in liftIO $ void $ swapMVar (ctxHandshake ctx) hs
Network/TLS/Handshake/Server.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style@@ -19,7 +20,7 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials-import Network.TLS.Crypto.ECDH+import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Util (catchException, fromJust) import Network.TLS.IO@@ -30,9 +31,16 @@ import Network.TLS.Handshake.Key import Network.TLS.Measurement import Data.Maybe (isJust, listToMaybe, mapMaybe)-import Data.List (intersect, sortBy)+import Data.List (intersect) import qualified Data.ByteString as B import Data.ByteString.Char8 ()+import Data.Ord (Down(..))+#if MIN_VERSION_base(4,8,0)+import Data.List (sortOn)+#else+import Data.List (sortBy)+import Data.Ord (comparing)+#endif import Control.Monad.State @@ -95,7 +103,11 @@ -- Handle Client hello processHandshake ctx clientHello - when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)+ -- rejecting SSL2. RFC 6176+ when (clientVersion == SSL2) $ throwCore $ Error_Protocol ("SSL 2.0 is not supported", True, ProtocolVersion)+ -- rejecting SSL3. RFC 7568+ -- when (clientVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, ProtocolVersion)+ -- Fallback SCSV: RFC7507 -- TLS_FALLBACK_SCSV: {0x56, 0x00} when (supportedFallbackScsv (ctxSupported ctx) &&@@ -106,26 +118,60 @@ 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) - let serverName = case extensionDecode False `fmap` (extensionLookup extensionID_ServerName exts) of- Just (Just (ServerName ns)) -> listToMaybe (mapMaybe toHostName ns)+ -- SNI (Server Name Indication)+ let serverName = case extensionLookup extensionID_ServerName exts >>= extensionDecode False of+ Just (ServerName ns) -> listToMaybe (mapMaybe toHostName ns) where toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing- _ -> Nothing+ _ -> Nothing extraCreds <- (onServerNameIndication $ serverHooks sparams) serverName + -- When selecting a cipher we must ensure that it is allowed for the+ -- TLS version but also that all its key-exchange requirements+ -- will be met.++ -- Some ciphers require a signature and a hash. With TLS 1.2 the hash+ -- algorithm is selected from a combination of server configuration and+ -- the client "supported_signatures" extension. So we cannot pick+ -- such a cipher if no hash is available for it. It's best to skip this+ -- cipher and pick another one (with another key exchange).++ -- FIXME ciphers should also be checked for other requirements+ -- (i.e. elliptic curves and D-H groups)+ let cipherAllowed cipher = case chosenVersion of+ TLS12 -> let -- Build a list of all signature algorithms with at least+ -- one hash algorithm in common between client and server.+ -- May contain duplicates, as it is only used for `elem`.+ possibleSigAlgs = map snd (hashAndSignaturesInCommon ctx exts)++ -- Check that a candidate cipher with a signature requiring+ -- a hash will have at least one hash available. This avoids+ -- a failure later in 'decideHash'.+ hasSigningRequirements =+ case cipherKeyExchange cipher of+ CipherKeyExchange_DHE_RSA -> SignatureRSA `elem` possibleSigAlgs+ CipherKeyExchange_DHE_DSS -> SignatureDSS `elem` possibleSigAlgs+ CipherKeyExchange_ECDHE_RSA -> SignatureRSA `elem` possibleSigAlgs+ CipherKeyExchange_ECDHE_ECDSA -> SignatureECDSA `elem` possibleSigAlgs+ _ -> True -- signature not used++ in cipherAllowedForVersion chosenVersion cipher && hasSigningRequirements+ _ -> cipherAllowedForVersion chosenVersion cipher+ -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists.- let ciphersFilteredVersion = filter (cipherAllowedForVersion chosenVersion) (commonCiphers extraCreds)+ let ciphersFilteredVersion = filter cipherAllowed (commonCiphers extraCreds) when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol ("no cipher in common with the client", True, HandshakeFailure) let usedCipher = (onCipherChoosing $ serverHooks sparams) chosenVersion ciphersFilteredVersion- creds = extraCreds `mappend` (sharedCredentials $ ctxShared ctx)+ creds = extraCreds `mappend` sharedCredentials (ctxShared ctx) cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds@@ -141,24 +187,24 @@ maybe (return ()) (usingState_ ctx . setClientSNI) serverName - case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of- Just (Just (ApplicationLayerProtocolNegotiation protos)) -> usingState_ ctx $ setClientALPNSuggest protos+ case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode False of+ Just (ApplicationLayerProtocolNegotiation protos) -> usingState_ ctx $ setClientALPNSuggest protos _ -> return () - case extensionDecode False `fmap` (extensionLookup extensionID_EllipticCurves exts) of- Just (Just (EllipticCurvesSupported es)) -> usingState_ ctx $ setClientEllipticCurveSuggest es+ case extensionLookup extensionID_EllipticCurves exts >>= extensionDecode False of+ Just (EllipticCurvesSupported es) -> usingState_ ctx $ setClientEllipticCurveSuggest es _ -> return () -- Currently, we don't send back EcPointFormats. In this case, -- the client chooses EcPointFormat_Uncompressed.- case extensionDecode False `fmap` (extensionLookup extensionID_EcPointFormats exts) of- Just (Just (EcPointFormatsSupported fs)) -> usingState_ ctx $ setClientEcPointFormatSuggest fs+ case extensionLookup extensionID_EcPointFormats exts >>= extensionDecode False of+ Just (EcPointFormatsSupported fs) -> usingState_ ctx $ setClientEcPointFormatSuggest fs _ -> return () doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where- commonCipherIDs extra = intersect ciphers (map cipherID $ (ctxCiphers ctx extra))+ commonCipherIDs extra = ciphers `intersect` map cipherID (ctxCiphers ctx extra) commonCiphers extra = filter (flip elem (commonCipherIDs extra) . cipherID) (ctxCiphers ctx extra) commonCompressions = compressionIntersectID (supportedCompressions $ ctxSupported ctx) compressions usedCompression = head commonCompressions@@ -194,14 +240,14 @@ if null protos then npn else return protos alpn | clientALPNSuggest = do- suggest <- usingState_ ctx $ getClientALPNSuggest+ 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+ return [ ExtensionRaw extensionID_ApplicationLayerProtocolNegotiation (extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ] (_, _) -> return [] | otherwise = return []@@ -226,7 +272,7 @@ -- --- makeServerHello session = do- srand <- getStateRNG ctx 32 >>= return . ServerRandom+ srand <- ServerRandom <$> getStateRNG ctx 32 case mcred of Just (_, privkey) -> usingHState ctx $ setPrivateKey privkey _ -> return () -- return a sensible error@@ -240,10 +286,23 @@ cvf <- getVerifiedData ClientRole svf <- getVerifiedData ServerRole return $ extensionEncode (SecureRenegotiation cvf $ Just svf)- return [ ExtensionRaw 0xff01 vf ]+ return [ ExtensionRaw extensionID_SecureRenegotiation vf ] else return [] protoExt <- applicationProtocol- let extensions = secRengExt ++ protoExt+ sniExt <- do+ resuming <- usingState_ ctx isSessionResuming+ if resuming+ then return []+ else do+ msni <- usingState_ ctx getClientSNI+ case msni of+ -- RFC6066: In this event, the server SHALL include+ -- an extension of type "server_name" in the+ -- (extended) server hello. The "extension_data"+ -- field of this extension SHALL be empty.+ Just _ -> return [ ExtensionRaw extensionID_ServerName ""]+ Nothing -> return []+ let extensions = secRengExt ++ protoExt ++ sniExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher)@@ -298,12 +357,29 @@ let serverParams = serverDHParamsFrom dhparams pub usingHState ctx $ setServerDHParams serverParams- usingHState ctx $ modify $ \hst -> hst { hstDHPrivate = Just priv }- return (serverParams)+ usingHState ctx $ setDHPrivate priv+ return serverParams + -- Choosing a hash algorithm to sign (EC)DHE parameters+ -- in ServerKeyExchange. Hash algorithm is not suggested by+ -- the chosen cipher suite. So, it should be selected based on+ -- the "signature_algorithms" extension in a client hello.+ -- If RSA is also used for key exchange, this function is+ -- not called.+ decideHash sigAlg = do+ usedVersion <- usingState_ ctx getVersion+ case usedVersion of+ TLS12 -> do+ let hashSigs = hashAndSignaturesInCommon ctx exts+ case filter ((==) sigAlg . snd) hashSigs of+ [] -> error ("no hash signature for " ++ show sigAlg)+ x:_ -> return $ Just (fst x)+ _ -> return Nothing+ generateSKX_DHE sigAlg = do serverParams <- setup_DHE- signed <- digitallySignDHParams ctx serverParams sigAlg+ mhash <- decideHash sigAlg+ signed <- digitallySignDHParams ctx serverParams sigAlg mhash case sigAlg of SignatureRSA -> return $ SKX_DHE_RSA serverParams signed SignatureDSS -> return $ SKX_DHE_DSS serverParams signed@@ -318,18 +394,19 @@ let serverParams = ServerECDHParams ecdhparams pub usingHState ctx $ setServerECDHParams serverParams- usingHState ctx $ modify $ \hst -> hst { hstECDHPrivate = Just priv }+ usingHState ctx $ setECDHPrivate priv return (serverParams) generateSKX_ECDHE sigAlg = do- ncs <- usingState_ ctx $ getClientEllipticCurveSuggest+ ncs <- usingState_ ctx getClientEllipticCurveSuggest let common = availableEllipticCurves `intersect` fromJust "ClientEllipticCurveSuggest" ncs -- FIXME: Currently maximum strength is chosen. -- There may be a better way to choose EC. nc = if null common then error "No common EllipticCurves" else maximum $ map fromEnumSafe16 common serverParams <- setup_ECDHE nc- signed <- digitallySignECDHParams ctx serverParams sigAlg+ mhash <- decideHash sigAlg+ signed <- digitallySignECDHParams ctx serverParams sigAlg mhash case sigAlg of SignatureRSA -> return $ SKX_ECDHE_RSA serverParams signed _ -> error ("generate skx_ecdhe unsupported signature type: " ++ show sigAlg)@@ -349,7 +426,7 @@ recvClientData sparams ctx = runRecvState ctx (RecvStateHandshake processClientCertificate) where processClientCertificate (Certificates certs) = do -- run certificate recv hook- ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs)+ ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs) -- Call application callback to see whether the -- certificate chain is acceptable. --@@ -378,7 +455,7 @@ -- Check whether the client correctly signed the handshake. -- If not, ask the application on how to proceed. --- processCertificateVerify (Handshake [hs@(CertVerify dsig@(DigitallySigned mbHashSig _))]) = do+ processCertificateVerify (Handshake [hs@(CertVerify dsig)]) = do processHandshake ctx hs checkValidClientCertChain "change cipher message expected"@@ -386,14 +463,19 @@ usedVersion <- usingState_ ctx getVersion -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages- verif <- certificateVerifyCheck ctx usedVersion mbHashSig msgs dsig + sigAlgExpected <- getRemoteSignatureAlg++ -- FIXME should check certificate is allowed for signing++ verif <- certificateVerifyCheck ctx usedVersion sigAlgExpected msgs dsig+ case verif of True -> do -- When verification succeeds, commit the -- client certificate chain to the context. --- Just certs <- usingHState ctx $ getClientCertChain+ Just certs <- usingHState ctx getClientCertChain usingState_ ctx $ setClientCertificateChain certs return () @@ -410,19 +492,27 @@ -- application callbacks accepts, we -- also commit the client certificate -- chain to the context.- Just certs <- usingHState ctx $ getClientCertChain+ Just certs <- usingHState ctx getClientCertChain usingState_ ctx $ setClientCertificateChain certs else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) return $ RecvStateNext expectChangeCipher processCertificateVerify p = do- chain <- usingHState ctx $ getClientCertChain+ chain <- usingHState ctx getClientCertChain case chain of Just cc | isNullCertificateChain cc -> return () | otherwise -> throwCore $ Error_Protocol ("cert verify message missing", True, UnexpectedMessage) Nothing -> return () expectChangeCipher p + getRemoteSignatureAlg = do+ pk <- usingHState ctx getRemotePublicKey+ case pk of+ PubKeyRSA _ -> return SignatureRSA+ PubKeyDSA _ -> return SignatureDSS+ PubKeyEC _ -> return SignatureECDSA+ _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure)+ expectChangeCipher ChangeCipherSpec = do npn <- usingState_ ctx getExtensionNPN return $ RecvStateHandshake $ if npn then expectNPN else expectFinish@@ -435,15 +525,36 @@ expectFinish p = unexpected (show p) (Just "Handshake Finished") checkValidClientCertChain msg = do- chain <- usingHState ctx $ getClientCertChain+ 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 () +hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]+hashAndSignaturesInCommon ctx exts =+ let cHashSigs = case extensionLookup extensionID_SignatureAlgorithms exts >>= extensionDecode False of+ -- See Section 7.4.1.4.1 of RFC 5246.+ Nothing -> [(HashSHA1, SignatureECDSA)+ ,(HashSHA1, SignatureRSA)+ ,(HashSHA1, SignatureDSS)]+ Just (SignatureAlgorithms sas) -> sas+ sHashSigs = supportedHashSignatures $ ctxSupported ctx+ -- The values in the "signature_algorithms" extension+ -- are in descending order of preference.+ -- However here the algorithms are selected according+ -- to server preference in 'supportedHashSignatures'.+ in sHashSigs `intersect` cHashSigs+ findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions =- case filter (clientVersion >=) $ reverse $ sortBy compare allowedVersions of+ case filter (clientVersion >=) $ sortOn Down allowedVersions of [] -> Nothing v:_ -> Just v++#if !MIN_VERSION_base(4,8,0)+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f =+ map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))+#endif
Network/TLS/Handshake/Signature.hs view
@@ -20,8 +20,8 @@ import Network.TLS.Context.Internal import Network.TLS.Struct import Network.TLS.Imports-import Network.TLS.Packet (generateCertificateVerify_SSL, encodeSignedDHParams, encodeSignedECDHParams)-import Network.TLS.Parameters (supportedHashSignatures)+import Network.TLS.Packet (generateCertificateVerify_SSL, generateCertificateVerify_SSL_DSS,+ encodeSignedDHParams, encodeSignedECDHParams) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Key@@ -31,49 +31,56 @@ certificateVerifyCheck :: Context -> Version- -> Maybe HashAndSignatureAlgorithm+ -> SignatureAlgorithm -> Bytes -> DigitallySigned -> IO Bool-certificateVerifyCheck ctx usedVersion malg msgs dsig =- prepareCertificateVerifySignatureData ctx usedVersion malg msgs >>=- signatureVerifyWithHashDescr ctx SignatureRSA dsig+certificateVerifyCheck ctx usedVersion sigAlgExpected msgs digSig@(DigitallySigned hashSigAlg _) =+ case (usedVersion, hashSigAlg) of+ (TLS12, Nothing) -> return False+ (TLS12, Just (h,s)) | s == sigAlgExpected -> doVerify (Just h)+ | otherwise -> return False+ (_, Nothing) -> doVerify Nothing+ (_, Just _) -> return False+ where+ doVerify mhash =+ prepareCertificateVerifySignatureData ctx usedVersion sigAlgExpected mhash msgs >>=+ signatureVerifyWithHashDescr ctx sigAlgExpected digSig certificateVerifyCreate :: Context -> Version- -> Maybe HashAndSignatureAlgorithm+ -> SignatureAlgorithm+ -> Maybe HashAlgorithm -- TLS12 only -> Bytes -> IO DigitallySigned-certificateVerifyCreate ctx usedVersion malg msgs =- prepareCertificateVerifySignatureData ctx usedVersion malg msgs >>=- signatureCreate ctx malg--getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m Hash-getHashAndASN1 hashSig = case hashSig of- (HashSHA1, SignatureRSA) -> return SHA1- (HashSHA224, SignatureRSA) -> return SHA224- (HashSHA256, SignatureRSA) -> return SHA256- (HashSHA384, SignatureRSA) -> return SHA384- (HashSHA512, SignatureRSA) -> return SHA512- _ -> throwCore $ Error_Misc "unsupported hash/sig algorithm"+certificateVerifyCreate ctx usedVersion sigAlg mhash msgs =+ prepareCertificateVerifySignatureData ctx usedVersion sigAlg mhash msgs >>=+ signatureCreateWithHashDescr ctx (toAlg `fmap` mhash)+ where+ toAlg hashAlg = (hashAlg, sigAlg) type CertVerifyData = (Hash, Bytes) prepareCertificateVerifySignatureData :: Context -> Version- -> Maybe HashAndSignatureAlgorithm+ -> SignatureAlgorithm+ -> Maybe HashAlgorithm -- TLS12 only -> Bytes -> IO CertVerifyData-prepareCertificateVerifySignatureData ctx usedVersion malg msgs+prepareCertificateVerifySignatureData ctx usedVersion sigAlg mhash msgs | usedVersion == SSL3 = do+ (h, generateCV_SSL) <-+ case sigAlg of+ SignatureRSA -> return (SHA1_MD5, generateCertificateVerify_SSL)+ SignatureDSS -> return (SHA1, generateCertificateVerify_SSL_DSS)+ _ -> throwCore $ Error_Misc ("unsupported CertificateVerify signature for SSL3: " ++ show sigAlg) Just masterSecret <- usingHState ctx $ gets hstMasterSecret- return (SHA1_MD5, generateCertificateVerify_SSL masterSecret (hashUpdate (hashInit SHA1_MD5) msgs))- | usedVersion == TLS10 || usedVersion == TLS11 = do- return (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) msgs)- | otherwise = do- let Just hashSig = malg- hsh <- getHashAndASN1 hashSig- return (hsh, msgs)+ return (h, generateCV_SSL masterSecret (hashUpdate (hashInit h) msgs))+ | usedVersion == TLS10 || usedVersion == TLS11 =+ case signatureHashData sigAlg Nothing of+ SHA1_MD5 -> return (SHA1_MD5, hashFinal $ hashUpdate (hashInit SHA1_MD5) msgs)+ alg -> return (alg, msgs)+ | otherwise = return (signatureHashData sigAlg mhash, msgs) signatureHashData :: SignatureAlgorithm -> Maybe HashAlgorithm -> Hash signatureHashData SignatureRSA mhash =@@ -95,20 +102,29 @@ Just HashSHA384 -> SHA384 Just HashSHA256 -> SHA256 Just HashSHA1 -> SHA1- Nothing -> SHA1_MD5+ Nothing -> SHA1 Just hsh -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) signatureHashData sig _ = error ("unimplemented signature type: " ++ show sig) --signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> HashDescr -> Bytes -> IO DigitallySigned signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned-signatureCreate ctx malg (hashAlg, toSign) = do- cc <- usingState_ ctx $ isClientContext+signatureCreate ctx malg (hashAlg, toSign) =+ -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as+ -- the SHA_MD5 algorithm expect an already digested data let signData = case (malg, hashAlg) of (Nothing, SHA1_MD5) -> hashFinal $ hashUpdate (hashInit SHA1_MD5) toSign _ -> toSign- DigitallySigned malg <$> signPrivate ctx cc hashAlg signData+ in signatureCreateWithHashDescr ctx malg (hashAlg, signData) +signatureCreateWithHashDescr :: Context+ -> Maybe HashAndSignatureAlgorithm+ -> CertVerifyData+ -> IO DigitallySigned+signatureCreateWithHashDescr ctx malg (hashDescr, toSign) = do+ cc <- usingState_ ctx $ isClientContext+ DigitallySigned malg <$> signPrivate ctx cc hashDescr toSign+ signatureVerify :: Context -> DigitallySigned -> SignatureAlgorithm -> Bytes -> IO Bool signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do usedVersion <- usingState_ ctx getVersion@@ -138,32 +154,28 @@ SignatureECDSA -> verifyPublic ctx cc hashDescr toVerify bs _ -> error "signature verification not implemented yet" -digitallySignParams :: Context -> Bytes -> SignatureAlgorithm -> IO DigitallySigned-digitallySignParams ctx signatureData sigAlg = do- usedVersion <- usingState_ ctx getVersion- let mhash = case usedVersion of- TLS12 -> case filter ((==) sigAlg . snd) $ supportedHashSignatures $ ctxSupported ctx of- [] -> error ("no hash signature for " ++ show sigAlg)- x:_ -> Just (fst x)- _ -> Nothing+digitallySignParams :: Context -> Bytes -> SignatureAlgorithm -> Maybe HashAlgorithm -> IO DigitallySigned+digitallySignParams ctx signatureData sigAlg mhash = do let hashDescr = signatureHashData sigAlg mhash signatureCreate ctx (fmap (\h -> (h, sigAlg)) mhash) (hashDescr, signatureData) digitallySignDHParams :: Context -> ServerDHParams -> SignatureAlgorithm+ -> Maybe HashAlgorithm -- TLS12 only -> IO DigitallySigned-digitallySignDHParams ctx serverParams sigAlg = do+digitallySignDHParams ctx serverParams sigAlg mhash = do dhParamsData <- withClientAndServerRandom ctx $ encodeSignedDHParams serverParams- digitallySignParams ctx dhParamsData sigAlg+ digitallySignParams ctx dhParamsData sigAlg mhash digitallySignECDHParams :: Context -> ServerECDHParams -> SignatureAlgorithm+ -> Maybe HashAlgorithm -- TLS12 only -> IO DigitallySigned-digitallySignECDHParams ctx serverParams sigAlg = do+digitallySignECDHParams ctx serverParams sigAlg mhash = do ecdhParamsData <- withClientAndServerRandom ctx $ encodeSignedECDHParams serverParams- digitallySignParams ctx ecdhParamsData sigAlg+ digitallySignParams ctx ecdhParamsData sigAlg mhash digitallySignDHParamsVerify :: Context -> ServerDHParams
Network/TLS/Handshake/State.hs view
@@ -20,7 +20,13 @@ , getLocalPrivateKey , getRemotePublicKey , setServerDHParams+ , getServerDHParams , setServerECDHParams+ , getServerECDHParams+ , setDHPrivate+ , getDHPrivate+ , setECDHPrivate+ , getECDHPrivate -- * cert accessors , setClientCertSent , getClientCertSent@@ -138,11 +144,29 @@ getLocalPrivateKey :: HandshakeM PrivKey getLocalPrivateKey = fromJust "local private key" <$> gets (hksLocalPrivateKey . hstKeyState) +getServerDHParams :: HandshakeM ServerDHParams+getServerDHParams = fromJust "server DH params" <$> gets hstServerDHParams++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 })++getDHPrivate :: HandshakeM DHPrivate+getDHPrivate = fromJust "server DH private" <$> gets hstDHPrivate++getECDHPrivate :: HandshakeM ECDHPrivate+getECDHPrivate = fromJust "server ECDH private" <$> gets hstECDHPrivate++setDHPrivate :: DHPrivate -> HandshakeM ()+setDHPrivate shp = modify (\hst -> hst { hstDHPrivate = Just shp })++setECDHPrivate :: ECDHPrivate -> HandshakeM ()+setECDHPrivate shp = modify (\hst -> hst { hstECDHPrivate = Just shp }) setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b })
Network/TLS/IO.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.IO
Network/TLS/Packet.hs view
@@ -52,6 +52,7 @@ , generateServerFinished , generateCertificateVerify_SSL+ , generateCertificateVerify_SSL_DSS -- * for extensions parsing , getSignatureHashAlgorithm@@ -666,8 +667,19 @@ | ver < TLS10 = generateFinished_SSL "SRVR" | otherwise = generateFinished_TLS (getPRF ver ciph) "server finished" +{- returns *output* after final MD5/SHA1 -} generateCertificateVerify_SSL :: Bytes -> HashCtx -> Bytes generateCertificateVerify_SSL = generateFinished_SSL ""++{- returns *input* before final SHA1 -}+generateCertificateVerify_SSL_DSS :: Bytes -> HashCtx -> Bytes+generateCertificateVerify_SSL_DSS mastersecret hashctx = toHash+ where toHash = B.concat [ mastersecret, pad2, sha1left ]++ sha1left = hashFinal $ flip hashUpdate pad1+ $ hashUpdate hashctx mastersecret+ pad2 = B.replicate 40 0x5c+ pad1 = B.replicate 40 0x36 encodeSignedDHParams :: ServerDHParams -> ClientRandom -> ServerRandom -> Bytes encodeSignedDHParams dhparams cran sran = runPut $
Network/TLS/Parameters.hs view
@@ -153,7 +153,14 @@ -- | supported compressions methods , supportedCompressions :: [Compression] -- | All supported hash/signature algorithms pair for client- -- certificate verification, ordered by decreasing priority.+ -- 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 hash and+ -- signature algorithm, 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'. , supportedHashSignatures :: [HashAndSignatureAlgorithm] -- | Secure renegotiation defined in RFC5746. -- If 'True', clients send the renegotiation_info extension.@@ -246,6 +253,10 @@ Maybe [HashAndSignatureAlgorithm], [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString)+ -- | 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] , onSuggestALPN :: IO (Maybe [B.ByteString]) }@@ -272,9 +283,8 @@ onClientCertificate :: CertificateChain -> IO CertificateUsage -- | This action is called when the client certificate- -- cannot be verified. A 'Nothing' argument indicates a- -- wrong signature, a 'Just e' message signals a crypto- -- error.+ -- cannot be verified. Return 'True' to accept the certificate+ -- anyway, or 'False' to fail verification. , onUnverifiedClientCert :: IO Bool -- | Allow the server to choose the cipher relative to the
Network/TLS/Record/State.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -- |
Network/TLS/Wire.hs view
@@ -22,6 +22,7 @@ , getWord16 , getWords16 , getWord24+ , getWord32 , getBytes , getOpaque8 , getOpaque16@@ -38,6 +39,7 @@ , putWord16 , putWords16 , putWord24+ , putWord32 , putBytes , putOpaque8 , putOpaque16@@ -103,6 +105,9 @@ b <- fromIntegral <$> getWord8 c <- fromIntegral <$> getWord8 return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c++getWord32 :: Get Word32+getWord32 = getWord32be getOpaque8 :: Get Bytes getOpaque8 = getWord8 >>= getBytes . fromIntegral
Tests/Connection.hs view
@@ -1,10 +1,17 @@ module Connection ( newPairContext , arbitraryPairParams+ , arbitraryPairParamsWithVersionsAndCiphers+ , arbitraryClientCredential , setPairParamsSessionManager , setPairParamsSessionResuming , establishDataPipe+ , initiateDataPipe , blockCipher+ , blockCipherDHE_RSA+ , blockCipherDHE_DSS+ , blockCipherECDHE_RSA+ , blockCipherECDHE_RSA_SHA384 , streamCipher ) where @@ -13,6 +20,7 @@ import PubKey import PipeChan import Network.TLS+import Network.TLS.Extra.FFDHE import Data.X509 import Data.Default.Class import Control.Applicative@@ -102,38 +110,57 @@ knownVersions :: [Version] knownVersions = [SSL3,TLS10,TLS11,TLS12] -arbitraryPairParams = do- (dsaPub, dsaPriv) <- (\(p,r) -> (PubKeyDSA p, PrivKeyDSA r)) <$> arbitraryDSAPair- let (pubKey, privKey) = (\(p, r) -> (PubKeyRSA p, PrivKeyRSA r)) $ getGlobalRSAPair- creds <- mapM (\(pub, priv) -> do- cert <- arbitraryX509WithKey (pub, priv)- return (CertificateChain [cert], priv)- ) [ (pubKey, privKey), (dsaPub, dsaPriv) ]- connectVersion <- elements knownVersions+arbitraryCredentialsOfEachType = do+ let (pubKey, privKey) = getGlobalRSAPair+ (dsaPub, dsaPriv) <- arbitraryDSAPair+ mapM (\(pub, priv) -> do+ cert <- arbitraryX509WithKey (pub, priv)+ return (CertificateChain [cert], priv)+ ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey)+ , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv)+ ]++arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher])+arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` (\cs -> or [maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) clientCiphers <- oneof [arbitraryCiphers] `suchThat` (\cs -> or [x `elem` serverCiphers && maybe True (<= connectVersion) (cipherMinVer x) | x <- cs])+ return (clientCiphers, serverCiphers)+ where+ arbitraryCiphers = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers)++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 let allowedVersions = [ v | v <- knownVersions, or [ x `elem` serverCiphers && maybe True (<= v) (cipherMinVer x) | x <- clientCiphers ]] serAllowedVersions <- (:[]) `fmap` elements allowedVersions- secNeg <- arbitrary+ arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) +arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version])+ -> ([Cipher], [Cipher])+ -> Gen (ClientParams, ServerParams)+arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do+ secNeg <- arbitrary+ dhparams <- elements [dhParams,ffdhe2048,ffdhe3072] + creds <- arbitraryCredentialsOfEachType let serverState = def { serverSupported = def { supportedCiphers = serverCiphers- , supportedVersions = serAllowedVersions+ , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg }- , serverDHEParams = Just dhParams+ , serverDHEParams = Just dhparams , serverShared = def { sharedCredentials = Credentials creds } } let clientState = (defaultParamsClient "" B.empty) { clientSupported = def { supportedCiphers = clientCiphers- , supportedVersions = allowedVersions+ , supportedVersions = clientVersions , supportedSecureRenegotiation = secNeg } , clientShared = def { sharedValidationCache = ValidationCache@@ -143,9 +170,10 @@ } } return (clientState, serverState)- where- arbitraryCiphers = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers) +arbitraryClientCredential :: Gen Credential+arbitraryClientCredential = arbitraryCredentialsOfEachType >>= elements+ setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams) setPairParamsSessionManager manager (clientState, serverState) = (nc,ns) where nc = clientState { clientShared = updateSessionManager $ clientShared clientState }@@ -197,3 +225,27 @@ putStrLn $ s ++ " exception: " ++ show e ++ ", supported: " ++ show supported E.throw e++initiateDataPipe params tlsServer tlsClient = do+ -- initial setup+ pipe <- newPipe+ _ <- (runPipe pipe)+ cQueue <- newChan+ sQueue <- newChan++ (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)++ writeSuccess :: Chan (Either E.SomeException a) -> a -> IO ()+ writeSuccess queue res = writeChan queue (Right res)
Tests/Tests.hs view
@@ -10,6 +10,7 @@ import Ciphers import Data.Maybe+import Data.List (intersect) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8@@ -55,10 +56,7 @@ Just d `assertEq` dres return () -prop_handshake_initiate :: PropertyM IO ()-prop_handshake_initiate = do- params <- pick arbitraryPairParams- runTLSPipe params tlsServer tlsClient+runTLSPipeSimple params = runTLSPipe params tlsServer tlsClient where tlsServer ctx queue = do handshake ctx d <- recvDataNonNull ctx@@ -71,6 +69,66 @@ bye ctx return () +runTLSInitFailure params = do+ (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient)+ assertIsLeft cRes+ assertIsLeft sRes+ where tlsServer ctx = handshake ctx >> bye ctx >> return "server success"+ tlsClient ctx = handshake ctx >> bye ctx >> return "client success"++prop_handshake_initiate :: PropertyM IO ()+prop_handshake_initiate = do+ params <- pick arbitraryPairParams+ runTLSPipeSimple params++-- test TLS12 protocol extensions with non-default configuration+prop_handshake_initiate_tls12 :: PropertyM IO ()+prop_handshake_initiate_tls12 = do+ let clientVersions = [TLS12]+ serverVersions = [TLS12]+ ciphers = [ blockCipherECDHE_RSA_SHA384+ , blockCipherECDHE_RSA+ , blockCipherDHE_RSA+ , blockCipherDHE_DSS+ ]+ (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers+ (clientVersions, serverVersions)+ (ciphers, ciphers)+ clientHashSigs <- pick someHashSignatures+ serverHashSigs <- pick someHashSignatures+ let clientParam' = clientParam { clientSupported = (clientSupported clientParam)+ { supportedHashSignatures = clientHashSigs }+ }+ serverParam' = serverParam { serverSupported = (serverSupported serverParam)+ { supportedHashSignatures = serverHashSigs }+ }+ shouldFail = null (clientHashSigs `intersect` serverHashSigs)+ if shouldFail+ then runTLSInitFailure (clientParam',serverParam')+ else runTLSPipeSimple (clientParam',serverParam')+ where someHashSignatures = sublistOf [ (HashSHA512, SignatureRSA)+ , (HashSHA384, SignatureRSA)+ , (HashSHA256, SignatureRSA)+ , (HashSHA1, SignatureRSA)+ , (HashSHA1, SignatureDSS)+ ]++prop_handshake_client_auth_initiate :: PropertyM IO ()+prop_handshake_client_auth_initiate = do+ (clientParam,serverParam) <- pick arbitraryPairParams+ cred <- pick arbitraryClientCredential+ let clientParam' = clientParam { clientHooks = (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred }+ }+ serverParam' = serverParam { serverWantClientCert = True+ , serverHooks = (serverHooks serverParam)+ { onClientCertificate = validateChain cred }+ }+ runTLSPipeSimple (clientParam',serverParam')+ where validateChain cred chain+ | chain == fst cred = return CertificateUsageAccept+ | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)+ prop_handshake_npn_initiate :: PropertyM IO () prop_handshake_npn_initiate = do (clientParam,serverParam) <- pick arbitraryPairParams@@ -141,29 +199,22 @@ plainParams <- pick arbitraryPairParams let params = setPairParamsSessionManager sessionManager plainParams - runTLSPipe params tlsServer tlsClient+ runTLSPipeSimple params -- and resume sessionParams <- run $ readIORef sessionRef assert (isJust sessionParams) let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - runTLSPipe params2 tlsServer tlsClient- where tlsServer ctx queue = do- handshake ctx- d <- recvDataNonNull ctx- writeChan queue d- return ()- tlsClient queue ctx = do- handshake ctx- d <- readChan queue- sendData ctx (L.fromChunks [d])- bye ctx- return ()+ runTLSPipeSimple params2 assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) +assertIsLeft :: (Show b, Monad m) => Either a b -> m ()+assertIsLeft (Left _) = return()+assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure")+ main :: IO () main = defaultMain $ testGroup "tls" [ tests_marshalling@@ -182,6 +233,8 @@ tests_handshake = testGroup "Handshakes" [ testProperty "setup" (monadicIO prop_pipe_work) , testProperty "initiate" (monadicIO prop_handshake_initiate)+ , testProperty "initiate TLS12" (monadicIO prop_handshake_initiate_tls12)+ , testProperty "clientAuthInitiate" (monadicIO prop_handshake_client_auth_initiate) , testProperty "npnInitiate" (monadicIO prop_handshake_npn_initiate) , testProperty "renegociation" (monadicIO prop_handshake_renegociation) , testProperty "resumption" (monadicIO prop_handshake_session_resumption)
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.3.9+Version: 1.3.10 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -55,9 +55,9 @@ , x509 >= 1.6.5 && < 1.7.0 , x509-store >= 1.6 , x509-validation >= 1.6.5 && < 1.7.0- , async+ , async >= 2.0 if flag(network)- Build-Depends: network+ Build-Depends: network >= 2.4.0.0 cpp-options: -DINCLUDE_NETWORK if flag(hans) Build-Depends: hans@@ -68,6 +68,7 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher+ Network.TLS.Extra.FFDHE other-modules: Network.TLS.Cap Network.TLS.Struct Network.TLS.Core