Hello community,
here is the log from the commit of package ghc-tls for openSUSE:Factory checked in at 2017-04-14 13:38:49
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-tls (Old)
and /work/SRC/openSUSE:Factory/.ghc-tls.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-tls"
Fri Apr 14 13:38:49 2017 rev:11 rq:485164 version:1.3.10
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-tls/ghc-tls.changes 2017-02-03 17:40:18.222598923 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-tls.new/ghc-tls.changes 2017-04-14 13:38:50.793847363 +0200
@@ -1,0 +2,5 @@
+Mon Mar 27 12:38:43 UTC 2017 - psimons@suse.com
+
+- Update to version 1.3.10 revision 1 with cabal2obs.
+
+-------------------------------------------------------------------
Old:
----
tls-1.3.9.tar.gz
New:
----
tls-1.3.10.tar.gz
tls.cabal
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-tls.spec ++++++
--- /var/tmp/diff_new_pack.p8UVUD/_old 2017-04-14 13:38:52.237643311 +0200
+++ /var/tmp/diff_new_pack.p8UVUD/_new 2017-04-14 13:38:52.241642746 +0200
@@ -19,13 +19,14 @@
%global pkg_name tls
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.3.9
+Version: 1.3.10
Release: 0
Summary: TLS/SSL protocol native implementation (Server and Client)
License: BSD-3-Clause
Group: Development/Languages/Other
Url: https://hackage.haskell.org/package/%{pkg_name}
Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
+Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-asn1-encoding-devel
BuildRequires: ghc-asn1-types-devel
@@ -77,6 +78,7 @@
%prep
%setup -q -n %{pkg_name}-%{version}
+cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ tls-1.3.9.tar.gz -> tls-1.3.10.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Backend.hs new/tls-1.3.10/Network/TLS/Backend.hs
--- old/tls-1.3.9/Network/TLS/Backend.hs 2016-07-30 12:11:49.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Backend.hs 2016-12-20 08:24:41.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Cipher.hs new/tls-1.3.10/Network/TLS/Cipher.hs
--- old/tls-1.3.9/Network/TLS/Cipher.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Cipher.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Core.hs new/tls-1.3.10/Network/TLS/Core.hs
--- old/tls-1.3.9/Network/TLS/Core.hs 2016-12-04 07:54:32.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Core.hs 2016-12-20 08:24:41.000000000 +0100
@@ -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 =
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Credentials.hs new/tls-1.3.10/Network/TLS/Credentials.hs
--- old/tls-1.3.9/Network/TLS/Credentials.hs 2015-01-16 20:44:32.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Credentials.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Extra/Cipher.hs new/tls-1.3.10/Network/TLS/Extra/Cipher.hs
--- old/tls-1.3.9/Network/TLS/Extra/Cipher.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Extra/Cipher.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Extra/FFDHE.hs new/tls-1.3.10/Network/TLS/Extra/FFDHE.hs
--- old/tls-1.3.9/Network/TLS/Extra/FFDHE.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Extra/FFDHE.hs 2016-12-28 11:26:10.000000000 +0100
@@ -0,0 +1,62 @@
+-- |
+-- Module : Network.TLS.Extra
+-- License : BSD-style
+-- Maintainer : Kazu Yamamoto
+-- 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
+ }
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Extra.hs new/tls-1.3.10/Network/TLS/Extra.hs
--- old/tls-1.3.9/Network/TLS/Extra.hs 2014-10-13 10:02:04.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Extra.hs 2016-12-28 11:26:10.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/Client.hs new/tls-1.3.10/Network/TLS/Handshake/Client.hs
--- old/tls-1.3.9/Network/TLS/Handshake/Client.hs 2016-07-30 12:11:49.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Handshake/Client.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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,24 +245,38 @@
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
cv <- getVerifiedData ClientRole
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/Common.hs new/tls-1.3.10/Network/TLS/Handshake/Common.hs
--- old/tls-1.3.9/Network/TLS/Handshake/Common.hs 2016-05-12 07:52:42.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Handshake/Common.hs 2016-12-20 08:24:41.000000000 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Common
( handshakeFailed
, errorToAlert
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/Process.hs new/tls-1.3.10/Network/TLS/Handshake/Process.hs
--- old/tls-1.3.9/Network/TLS/Handshake/Process.hs 2016-05-07 10:39:05.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Handshake/Process.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/Server.hs new/tls-1.3.10/Network/TLS/Handshake/Server.hs
--- old/tls-1.3.9/Network/TLS/Handshake/Server.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Handshake/Server.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/Signature.hs new/tls-1.3.10/Network/TLS/Handshake/Signature.hs
--- old/tls-1.3.9/Network/TLS/Handshake/Signature.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Handshake/Signature.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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,19 +102,28 @@
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
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Handshake/State.hs new/tls-1.3.10/Network/TLS/Handshake/State.hs
--- old/tls-1.3.9/Network/TLS/Handshake/State.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Handshake/State.hs 2016-12-20 08:24:41.000000000 +0100
@@ -20,7 +20,13 @@
, getLocalPrivateKey
, getRemotePublicKey
, setServerDHParams
+ , getServerDHParams
, setServerECDHParams
+ , getServerECDHParams
+ , setDHPrivate
+ , getDHPrivate
+ , setECDHPrivate
+ , getECDHPrivate
-- * cert accessors
, setClientCertSent
, getClientCertSent
@@ -138,12 +144,30 @@
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 })
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/IO.hs new/tls-1.3.10/Network/TLS/IO.hs
--- old/tls-1.3.9/Network/TLS/IO.hs 2014-10-13 10:02:04.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/IO.hs 2016-12-20 08:24:41.000000000 +0100
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
-- |
-- Module : Network.TLS.IO
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Packet.hs new/tls-1.3.10/Network/TLS/Packet.hs
--- old/tls-1.3.9/Network/TLS/Packet.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Packet.hs 2017-03-14 07:12:25.000000000 +0100
@@ -52,6 +52,7 @@
, generateServerFinished
, generateCertificateVerify_SSL
+ , generateCertificateVerify_SSL_DSS
-- * for extensions parsing
, getSignatureHashAlgorithm
@@ -666,9 +667,20 @@
| 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 $
putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Parameters.hs new/tls-1.3.10/Network/TLS/Parameters.hs
--- old/tls-1.3.9/Network/TLS/Parameters.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Network/TLS/Parameters.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Record/State.hs new/tls-1.3.10/Network/TLS/Record/State.hs
--- old/tls-1.3.9/Network/TLS/Record/State.hs 2016-05-07 08:24:19.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Record/State.hs 2016-12-20 08:24:41.000000000 +0100
@@ -1,4 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
-- |
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Network/TLS/Wire.hs new/tls-1.3.10/Network/TLS/Wire.hs
--- old/tls-1.3.9/Network/TLS/Wire.hs 2015-09-21 23:00:21.000000000 +0200
+++ new/tls-1.3.10/Network/TLS/Wire.hs 2016-12-20 08:24:41.000000000 +0100
@@ -22,6 +22,7 @@
, getWord16
, getWords16
, getWord24
+ , getWord32
, getBytes
, getOpaque8
, getOpaque16
@@ -38,6 +39,7 @@
, putWord16
, putWords16
, putWord24
+ , putWord32
, putBytes
, putOpaque8
, putOpaque16
@@ -104,6 +106,9 @@
c <- fromIntegral <$> getWord8
return $ (a `shiftL` 16) .|. (b `shiftL` 8) .|. c
+getWord32 :: Get Word32
+getWord32 = getWord32be
+
getOpaque8 :: Get Bytes
getOpaque8 = getWord8 >>= getBytes . fromIntegral
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Tests/Connection.hs new/tls-1.3.10/Tests/Connection.hs
--- old/tls-1.3.9/Tests/Connection.hs 2016-12-17 12:09:25.000000000 +0100
+++ new/tls-1.3.10/Tests/Connection.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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,8 +170,9 @@
}
}
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)
@@ -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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/Tests/Tests.hs new/tls-1.3.10/Tests/Tests.hs
--- old/tls-1.3.9/Tests/Tests.hs 2015-08-10 11:37:10.000000000 +0200
+++ new/tls-1.3.10/Tests/Tests.hs 2017-03-14 07:12:25.000000000 +0100
@@ -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)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/tls-1.3.9/tls.cabal new/tls-1.3.10/tls.cabal
--- old/tls-1.3.9/tls.cabal 2016-12-17 12:54:03.000000000 +0100
+++ new/tls-1.3.10/tls.cabal 2017-03-14 08:08:04.000000000 +0100
@@ -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
++++++ tls.cabal ++++++
Name: tls
Version: 1.3.10
x-revision: 1
Description:
Native Haskell TLS and SSL protocol implementation for server and client.
.
This provides a high-level implementation of a sensitive security protocol,
eliminating a common set of security issues through the use of the advanced
type system, high level constructions and common Haskell features.
.
Currently implement the SSL3.0, TLS1.0, TLS1.1 and TLS1.2 protocol,
and support RSA and Ephemeral (Elliptic curve and regular) Diffie Hellman key exchanges,
and many extensions.
.
Some debug tools linked with tls, are available through the
http://hackage.haskell.org/package/tls-debug/.
License: BSD3
License-file: LICENSE
Copyright: Vincent Hanquez
Author: Vincent Hanquez
Maintainer: Vincent Hanquez
Synopsis: TLS/SSL protocol native implementation (Server and Client)
Build-Type: Simple
Category: Network
stability: experimental
Cabal-Version: >=1.8
Homepage: http://github.com/vincenthz/hs-tls
extra-source-files: Tests/*.hs
CHANGELOG.md
Flag compat
Description: Accept SSLv2 client hello for beginning SSLv3 / TLS handshake
Default: True
Flag network
Description: Use the base network library
Default: True
Flag hans
Description: Use the Haskell Network Stack (HaNS)
Default: False
Library
Build-Depends: base >= 4.6 && < 5
, mtl >= 2 && < 2.3
, transformers < 0.6
, cereal >= 0.4 && < 0.6
, bytestring < 0.11
, data-default-class < 0.2
-- crypto related
, memory < 0.15
, cryptonite >= 0.21 && < 0.23
-- certificate related
, asn1-types >= 0.2.0 && < 0.4
, asn1-encoding < 0.10
, x509 >= 1.6.5 && < 1.7
, x509-store >= 1.6 && < 1.7
, x509-validation >= 1.6.5 && < 1.7
, async >= 2.0 && < 2.2
if flag(network)
Build-Depends: network >= 2.4.0.0 && < 2.7
cpp-options: -DINCLUDE_NETWORK
if flag(hans)
Build-Depends: hans
cpp-options: -DINCLUDE_HANS
Exposed-modules: Network.TLS
Network.TLS.Cipher
Network.TLS.Compression
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
Network.TLS.Context
Network.TLS.Context.Internal
Network.TLS.Credentials
Network.TLS.Backend
Network.TLS.Crypto
Network.TLS.Crypto.DH
Network.TLS.Crypto.ECDH
Network.TLS.ErrT
Network.TLS.Extension
Network.TLS.Extension.EC
Network.TLS.Handshake
Network.TLS.Handshake.Common
Network.TLS.Handshake.Certificate
Network.TLS.Handshake.Key
Network.TLS.Handshake.Client
Network.TLS.Handshake.Server
Network.TLS.Handshake.Process
Network.TLS.Handshake.Signature
Network.TLS.Handshake.State
Network.TLS.Hooks
Network.TLS.IO
Network.TLS.Imports
Network.TLS.MAC
Network.TLS.Measurement
Network.TLS.Packet
Network.TLS.Parameters
Network.TLS.Record
Network.TLS.Record.Types
Network.TLS.Record.Engage
Network.TLS.Record.Disengage
Network.TLS.Record.State
Network.TLS.RNG
Network.TLS.State
Network.TLS.Session
Network.TLS.Sending
Network.TLS.Receiving
Network.TLS.Util
Network.TLS.Util.ASN1
Network.TLS.Util.Serialization
Network.TLS.Types
Network.TLS.Wire
Network.TLS.X509
ghc-options: -Wall -fwarn-tabs -fno-warn-unused-imports
if flag(compat)
cpp-options: -DSSLV2_COMPATIBLE
Test-Suite test-tls
type: exitcode-stdio-1.0
hs-source-dirs: Tests
Main-is: Tests.hs
other-modules: Certificate
Ciphers
Connection
Marshalling
PipeChan
PubKey
Build-Depends: base >= 3 && < 5
, mtl
, cereal >= 0.3
, data-default-class
, tasty
, tasty-quickcheck
, tls
, QuickCheck
, cryptonite
, bytestring
, x509
, x509-validation
, hourglass
ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs
Benchmark bench-tls
hs-source-dirs: Benchmarks Tests
Main-Is: Benchmarks.hs
type: exitcode-stdio-1.0
Build-depends: base >= 4 && < 5
, tls
, x509
, x509-validation
, data-default-class
, cryptonite
, criterion >= 1.0
, mtl
, bytestring
, hourglass
, QuickCheck >= 2
, tasty-quickcheck
, tls
source-repository head
type: git
location: https://github.com/vincenthz/hs-tls
subdir: core