tls 1.2.13 → 1.2.14
raw patch · 26 files changed
+887/−66 lines, 26 filesdep ~crypto-pubkey
Dependency ranges changed: crypto-pubkey
Files
- CHANGELOG.md +52/−0
- Network/TLS/Cipher.hs +17/−0
- Network/TLS/Context.hs +1/−1
- Network/TLS/Crypto.hs +2/−0
- Network/TLS/Crypto/ECDH.hs +77/−0
- Network/TLS/Extension.hs +228/−10
- Network/TLS/Extension/EC.hs +64/−0
- Network/TLS/Extra/Cipher.hs +37/−2
- Network/TLS/Handshake/Client.hs +67/−4
- Network/TLS/Handshake/Key.hs +4/−0
- Network/TLS/Handshake/Process.hs +11/−0
- Network/TLS/Handshake/Server.hs +84/−11
- Network/TLS/Handshake/Signature.hs +8/−1
- Network/TLS/Handshake/State.hs +10/−1
- Network/TLS/Packet.hs +57/−0
- Network/TLS/Parameters.hs +5/−1
- Network/TLS/Record/Disengage.hs +19/−0
- Network/TLS/Record/Engage.hs +57/−26
- Network/TLS/Record/State.hs +1/−0
- Network/TLS/Sending.hs +3/−1
- Network/TLS/State.hs +42/−1
- Network/TLS/Struct.hs +18/−0
- Network/TLS/Util/Serialization.hs +3/−1
- Network/TLS/Wire.hs +7/−0
- Tests/Ciphers.hs +8/−3
- tls.cabal +5/−3
CHANGELOG.md view
@@ -1,3 +1,55 @@+## Version HEAD++- adding ALPN extension+- adding support for AEAD, and particularly AES128-GCM+- Adding support for ECDH+- Do not support SSL3 by default for security reason.+- add EnumSafe8 and 16 for specific sized Enum instance that are safer+- export signatureAndHash parser/encoder+- add a "known" list of extensions+- add SignatureAlgorithms extension+- add Heartbeat extension+- add support for EC curves and point format extensions+- add preliminary SessionTicket extension+- Debug: Add the ability to choose arbitrary cipher in the client hello.++## Version 1.2.13++- Fix compilation with old mtl version++## Version 1.2.12++- Propagate asynchronous exception++## Version 1.2.11++- use hourglass instead of time+- use tasty instead of test-framework+- add travis file+- remove old de-optimisation flag as the bytestring bug is old now and it conflict with cabal check++## Version 1.2.10++- Update x509 dependencies++## Version 1.2.9++- Export TLSParams and HasBackend type names+- Added FlexibleContexts flag required by ghc-7.9+- debug: add support for specifying the timeout length in milliseconds.+- debug: add support for 3DES in simple client++## Version 1.2.8++- add support for 3DES-EDE-CBC-SHA1 (cipher 0xa)++## Version 1.2.7++- repair retrieve certificate validation, and improve fingerprints+- remove groom from dependency+- make RecordM an instance of Applicative+- Fixes the Error_EOF partial pattern match error in exception handling+ ## Version 1.2.6 (23 Mar 2014) - Fixed socket backend endless loop when the server does not close connection
Network/TLS/Cipher.hs view
@@ -16,11 +16,16 @@ , CipherID , Key , IV+ , Nonce+ , AdditionalData , cipherKeyBlockSize , cipherAllowedForVersion , cipherExchangeNeedMoreData+ , hasMAC+ , hasRecordIV ) where +import Crypto.Cipher.Types (AuthTag) import Network.TLS.Types (CipherID) import Network.TLS.Struct (Version(..)) @@ -29,6 +34,8 @@ -- FIXME convert to newtype type Key = B.ByteString type IV = B.ByteString+type Nonce = B.ByteString+type AdditionalData = B.ByteString data BulkFunctions = BulkBlockF (Key -> IV -> B.ByteString -> B.ByteString)@@ -36,6 +43,16 @@ | BulkStreamF (Key -> IV) (IV -> B.ByteString -> (B.ByteString, IV)) (IV -> B.ByteString -> (B.ByteString, IV))+ | BulkAeadF (Key -> Nonce -> B.ByteString -> AdditionalData -> (B.ByteString, AuthTag))+ (Key -> Nonce -> B.ByteString -> AdditionalData -> (B.ByteString, AuthTag))++hasMAC,hasRecordIV :: BulkFunctions -> Bool++hasMAC (BulkBlockF _ _) = True+hasMAC (BulkStreamF _ _ _) = True+hasMAC (BulkAeadF _ _ ) = False++hasRecordIV = hasMAC data CipherKeyExchangeType = CipherKeyExchange_RSA
Network/TLS/Context.hs view
@@ -114,11 +114,11 @@ CipherKeyExchange_DH_Anon -> canDHE CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE+ CipherKeyExchange_ECDHE_RSA -> canSignRSA -- unimplemented: non ephemeral DH CipherKeyExchange_DH_DSS -> False CipherKeyExchange_DH_RSA -> False -- unimplemented: EC- CipherKeyExchange_ECDHE_RSA -> False CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False CipherKeyExchange_ECDHE_ECDSA -> False
Network/TLS/Crypto.hs view
@@ -8,6 +8,7 @@ , hashFinal , module Network.TLS.Crypto.DH+ , module Network.TLS.Crypto.ECDH -- * constructor , hashMD5SHA1@@ -41,6 +42,7 @@ import Crypto.Random import Data.X509 (PrivKey(..), PubKey(..)) import Network.TLS.Crypto.DH+import Network.TLS.Crypto.ECDH import Data.ASN1.Types import Data.ASN1.Encoding
+ Network/TLS/Crypto/ECDH.hs view
@@ -0,0 +1,77 @@+module Network.TLS.Crypto.ECDH+ (+ -- * ECDH types+ ECDHParams(..)+ , ECDHPublic+ , ECDHPrivate(..)++ -- * ECDH methods+ , ecdhPublic+ , ecdhPrivate+ , ecdhParams+ , ecdhGenerateKeyPair+ , ecdhGetShared+ , ecdhUnwrap+ , ecdhUnwrapPublic+ ) where++import Network.TLS.Util.Serialization (i2osp, lengthBytes)+import Network.TLS.Extension.EC+import qualified Crypto.PubKey.ECC.DH as ECDH+import qualified Crypto.Types.PubKey.ECC as ECDH+import qualified Crypto.PubKey.ECC.Prim as ECC (isPointValid)+import Crypto.Random (CPRG)+import Data.ByteString (ByteString)+import Data.Word (Word16)++data ECDHPublic = ECDHPublic ECDH.PublicPoint Int {- byte size -}+ deriving (Show,Eq)+newtype ECDHPrivate = ECDHPrivate ECDH.PrivateNumber deriving (Show,Eq)+data ECDHParams = ECDHParams ECDH.Curve ECDH.CurveName deriving (Show,Eq)+type ECDHKey = ByteString++ecdhPublic :: Integer -> Integer -> Int -> ECDHPublic+ecdhPublic x y siz = ECDHPublic (ECDH.Point x y) siz++ecdhPrivate :: Integer -> ECDHPrivate+ecdhPrivate = ECDHPrivate++ecdhParams :: Word16 -> ECDHParams+ecdhParams w16 = ECDHParams curve name+ where+ Just name = toCurveName w16 -- FIXME+ curve = ECDH.getCurveByName name++ecdhGenerateKeyPair :: CPRG g => g -> ECDHParams -> ((ECDHPrivate, ECDHPublic), g)+ecdhGenerateKeyPair rng (ECDHParams curve _) =+ let (priv, g') = ECDH.generatePrivate rng curve+ siz = pointSize curve+ point = ECDH.calculatePublic curve priv+ pub = ECDHPublic point siz+ in ((ECDHPrivate priv, pub), g')++ecdhGetShared :: ECDHParams -> ECDHPrivate -> ECDHPublic -> Maybe ECDHKey+ecdhGetShared (ECDHParams curve _) (ECDHPrivate priv) (ECDHPublic point _)+ | ECC.isPointValid curve point =+ let ECDH.SharedKey sk = ECDH.getShared curve priv point+ in Just $ i2osp sk+ | otherwise =+ Nothing++-- for server key exchange+ecdhUnwrap :: ECDHParams -> ECDHPublic -> (Word16,Integer,Integer,Int)+ecdhUnwrap (ECDHParams _ name) point = (w16,x,y,siz)+ where+ w16 = case fromCurveName name of+ Just w -> w+ Nothing -> error "ecdhUnwrap"+ (x,y,siz) = ecdhUnwrapPublic point++-- for client key exchange+ecdhUnwrapPublic :: ECDHPublic -> (Integer,Integer,Int)+ecdhUnwrapPublic (ECDHPublic (ECDH.Point x y) siz) = (x,y,siz)+ecdhUnwrapPublic _ = error "ecdhUnwrapPublic"++pointSize :: ECDH.Curve -> Int+pointSize (ECDH.CurveFP curve) = lengthBytes $ ECDH.ecc_p curve+pointSize _ = error "pointSize" -- FIXME
Network/TLS/Extension.hs view
@@ -10,11 +10,17 @@ module Network.TLS.Extension ( Extension(..) , supportedExtensions+ , definedExtensions -- all extensions ID supported , extensionID_ServerName , extensionID_MaxFragmentLength , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation+ , extensionID_ApplicationLayerProtocolNegotiation+ , extensionID_EllipticCurves+ , extensionID_EcPointFormats+ , extensionID_Heartbeat+ , extensionID_SignatureAlgorithms -- all implemented extensions , ServerNameType(..) , ServerName(..)@@ -22,35 +28,132 @@ , MaxFragmentEnum(..) , SecureRenegotiation(..) , NextProtocolNegotiation(..)+ , ApplicationLayerProtocolNegotiation(..)+ , EllipticCurvesSupported(..)+ , NamedCurve(..)+ , CurveName(..)+ , EcPointFormatsSupported(..)+ , EcPointFormat(..)+ , SessionTicket(..)+ , HeartBeat(..)+ , HeartBeatMode(..)+ , SignatureAlgorithms(..)+ , availableEllipticCurves ) where -import Control.Applicative ((<$>))+import Control.Applicative ((<$>),(<*>)) import Control.Monad import Data.Word-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -import Network.TLS.Struct (ExtensionID)+import Network.TLS.Extension.EC+import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm) import Network.TLS.Wire+import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm) import Network.BSD (HostName) -extensionID_ServerName, extensionID_MaxFragmentLength- , extensionID_SecureRenegotiation- , extensionID_NextProtocolNegotiation :: ExtensionID-extensionID_ServerName = 0x0-extensionID_MaxFragmentLength = 0x1-extensionID_SecureRenegotiation = 0xff01-extensionID_NextProtocolNegotiation = 0x3374 +-- central list defined in <http://www.iana.org/assignments/tls-extensiontype-values/tls-extensiontype-values.txt>+extensionID_ServerName+ , extensionID_MaxFragmentLength+ , extensionID_ClientCertificateUrl+ , extensionID_TrustedCAKeys+ , extensionID_TruncatedHMAC+ , extensionID_StatusRequest+ , extensionID_UserMapping+ , extensionID_ClientAuthz+ , extensionID_ServerAuthz+ , extensionID_CertType+ , extensionID_EllipticCurves+ , extensionID_EcPointFormats+ , extensionID_SRP+ , extensionID_SignatureAlgorithms+ , extensionID_SRTP+ , extensionID_Heartbeat+ , extensionID_ApplicationLayerProtocolNegotiation+ , extensionID_StatusRequestv2+ , extensionID_SignedCertificateTimestamp+ , extensionID_ClientCertificateType+ , extensionID_ServerCertificateType+ , extensionID_Padding+ , extensionID_EncryptThenMAC+ , extensionID_ExtendedMasterSecret+ , extensionID_SessionTicket+ , extensionID_NextProtocolNegotiation+ , extensionID_SecureRenegotiation :: ExtensionID+extensionID_ServerName = 0x0 -- RFC6066+extensionID_MaxFragmentLength = 0x1 -- RFC6066+extensionID_ClientCertificateUrl = 0x2 -- RFC6066+extensionID_TrustedCAKeys = 0x3 -- RFC6066+extensionID_TruncatedHMAC = 0x4 -- RFC6066+extensionID_StatusRequest = 0x5 -- RFC6066+extensionID_UserMapping = 0x6 -- RFC4681+extensionID_ClientAuthz = 0x7 -- RFC5878+extensionID_ServerAuthz = 0x8 -- RFC5878+extensionID_CertType = 0x9 -- RFC6091+extensionID_EllipticCurves = 0xa -- RFC4492+extensionID_EcPointFormats = 0xb -- RFC4492+extensionID_SRP = 0xc -- RFC5054+extensionID_SignatureAlgorithms = 0xd -- RFC5246+extensionID_SRTP = 0xe -- RFC5764+extensionID_Heartbeat = 0xf -- RFC6520+extensionID_ApplicationLayerProtocolNegotiation = 0x10 -- RFC7301+extensionID_StatusRequestv2 = 0x11 -- RFC6961+extensionID_SignedCertificateTimestamp = 0x12 -- RFC6962+extensionID_ClientCertificateType = 0x13 -- RFC7250+extensionID_ServerCertificateType = 0x14 -- RFC7250+extensionID_Padding = 0x15 -- draft-agl-tls-padding. expires 2015-03-12+extensionID_EncryptThenMAC = 0x16 -- RFC7366+extensionID_ExtendedMasterSecret = 0x17 -- draft-ietf-tls-session-hash. expires 2015-09-26+extensionID_SessionTicket = 0x23 -- RFC4507+extensionID_NextProtocolNegotiation = 0x3374 -- obsolete+extensionID_SecureRenegotiation = 0xff01 -- RFC5746++definedExtensions :: [ExtensionID]+definedExtensions =+ [ extensionID_ServerName+ , extensionID_MaxFragmentLength+ , extensionID_ClientCertificateUrl+ , extensionID_TrustedCAKeys+ , extensionID_TruncatedHMAC+ , extensionID_StatusRequest+ , extensionID_UserMapping+ , extensionID_ClientAuthz+ , extensionID_ServerAuthz+ , extensionID_CertType+ , extensionID_EllipticCurves+ , extensionID_EcPointFormats+ , extensionID_SRP+ , extensionID_SignatureAlgorithms+ , extensionID_SRTP+ , extensionID_Heartbeat+ , extensionID_ApplicationLayerProtocolNegotiation+ , extensionID_StatusRequestv2+ , extensionID_SignedCertificateTimestamp+ , extensionID_ClientCertificateType+ , extensionID_ServerCertificateType+ , extensionID_Padding+ , extensionID_EncryptThenMAC+ , extensionID_ExtendedMasterSecret+ , extensionID_SessionTicket+ , extensionID_NextProtocolNegotiation+ , extensionID_SecureRenegotiation+ ]+ -- | all supported extensions by the implementation supportedExtensions :: [ExtensionID] supportedExtensions = [ extensionID_ServerName , extensionID_MaxFragmentLength+ , extensionID_ApplicationLayerProtocolNegotiation , extensionID_SecureRenegotiation , extensionID_NextProtocolNegotiation+ , extensionID_EllipticCurves+ , extensionID_EcPointFormats+ , extensionID_SignatureAlgorithms ] -- | Extension class to transform bytes to and from a high level Extension type.@@ -131,3 +234,118 @@ case avail of 0 -> return [] _ -> do liftM2 (:) getOpaque8 getNPN++-- | Application Layer Protocol Negotiation (ALPN)+data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString]+ deriving (Show,Eq)++instance Extension ApplicationLayerProtocolNegotiation where+ extensionID _ = extensionID_ApplicationLayerProtocolNegotiation+ extensionEncode (ApplicationLayerProtocolNegotiation bytes) =+ runPut $ putOpaque16 $ runPut $ mapM_ putOpaque8 bytes+ extensionDecode _ = runGetMaybe (ApplicationLayerProtocolNegotiation <$> getALPN)+ where getALPN = do+ _ <- getWord16+ getALPN'+ getALPN' = do+ avail <- remaining+ case avail of+ 0 -> return []+ _ -> (:) <$> getOpaque8 <*> getALPN'++data EllipticCurvesSupported = EllipticCurvesSupported [NamedCurve]+ deriving (Show,Eq)++data NamedCurve =+ SEC CurveName+ | NamedCurve_arbitrary_explicit_prime_curves+ | NamedCurve_arbitrary_explicit_char2_curves+ deriving (Show,Eq)++-- FIXME: currently maximum crypto strength of our supported+-- cipher suite is 128 bits. Not support 384 and 512.+availableEllipticCurves :: [NamedCurve]+availableEllipticCurves = [SEC SEC_p160r1, SEC SEC_p224r1, SEC SEC_p256r1]++instance EnumSafe16 NamedCurve where+ fromEnumSafe16 NamedCurve_arbitrary_explicit_prime_curves = 0xFF01+ fromEnumSafe16 NamedCurve_arbitrary_explicit_char2_curves = 0xFF02+ fromEnumSafe16 (SEC nc) = maybe (error "named curve: internal error") id $ fromCurveName nc+ toEnumSafe16 0xFF01 = Just NamedCurve_arbitrary_explicit_prime_curves+ toEnumSafe16 0xFF02 = Just NamedCurve_arbitrary_explicit_char2_curves+ toEnumSafe16 n = SEC <$> toCurveName n++-- on decode, filter all unknown curves+instance Extension EllipticCurvesSupported where+ extensionID _ = extensionID_EllipticCurves+ extensionEncode (EllipticCurvesSupported curves) = runPut $ putWords16 $ map fromEnumSafe16 curves+ extensionDecode _ = runGetMaybe (EllipticCurvesSupported . catMaybes . map toEnumSafe16 <$> getWords16)++data EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]+ deriving (Show,Eq)++data EcPointFormat =+ EcPointFormat_Uncompressed+ | EcPointFormat_AnsiX962_compressed_prime+ | EcPointFormat_AnsiX962_compressed_char2+ deriving (Show,Eq)++instance EnumSafe8 EcPointFormat where+ fromEnumSafe8 EcPointFormat_Uncompressed = 0+ fromEnumSafe8 EcPointFormat_AnsiX962_compressed_prime = 1+ fromEnumSafe8 EcPointFormat_AnsiX962_compressed_char2 = 2++ toEnumSafe8 0 = Just EcPointFormat_Uncompressed+ toEnumSafe8 1 = Just EcPointFormat_AnsiX962_compressed_prime+ toEnumSafe8 2 = Just EcPointFormat_AnsiX962_compressed_char2+ toEnumSafe8 _ = Nothing++-- on decode, filter all unknown formats+instance Extension EcPointFormatsSupported where+ extensionID _ = extensionID_EcPointFormats+ extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats+ extensionDecode _ = runGetMaybe (EcPointFormatsSupported . catMaybes . map toEnumSafe8 <$> getWords8)++data SessionTicket = SessionTicket+ deriving (Show,Eq)++instance Extension SessionTicket where+ extensionID _ = extensionID_SessionTicket+ extensionEncode (SessionTicket {}) = runPut $ return ()+ extensionDecode _ = runGetMaybe (return SessionTicket)++data HeartBeat = HeartBeat HeartBeatMode+ deriving (Show,Eq)++data HeartBeatMode =+ HeartBeat_PeerAllowedToSend+ | HeartBeat_PeerNotAllowedToSend+ deriving (Show,Eq)++instance EnumSafe8 HeartBeatMode where+ fromEnumSafe8 HeartBeat_PeerAllowedToSend = 1+ fromEnumSafe8 HeartBeat_PeerNotAllowedToSend = 2++ toEnumSafe8 1 = Just HeartBeat_PeerAllowedToSend+ toEnumSafe8 2 = Just HeartBeat_PeerNotAllowedToSend+ toEnumSafe8 _ = Nothing++instance Extension HeartBeat where+ extensionID _ = extensionID_Heartbeat+ extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromEnumSafe8 mode+ extensionDecode _ bs =+ case runGetMaybe (toEnumSafe8 <$> getWord8) bs of+ Just (Just mode) -> Just $ HeartBeat mode+ _ -> Nothing++data SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm]+ deriving (Show,Eq)++instance Extension SignatureAlgorithms where+ extensionID _ = extensionID_SignatureAlgorithms+ extensionEncode (SignatureAlgorithms algs) =+ runPut $ putWord16 (fromIntegral (length algs * 2)) >> mapM_ putSignatureHashAlgorithm algs+ extensionDecode _ =+ runGetMaybe $ do+ len <- getWord16+ SignatureAlgorithms <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))
+ Network/TLS/Extension/EC.hs view
@@ -0,0 +1,64 @@+module Network.TLS.Extension.EC (+ CurveName(..)+ , toCurveName+ , fromCurveName+ ) where++import Crypto.Types.PubKey.ECC (CurveName(..))+import Data.Word (Word16)++toCurveName :: Word16 -> Maybe CurveName+toCurveName 1 = Just SEC_t163k1+toCurveName 2 = Just SEC_t163r1+toCurveName 3 = Just SEC_t163r2+toCurveName 4 = Just SEC_t193r1+toCurveName 5 = Just SEC_t193r2+toCurveName 6 = Just SEC_t233k1+toCurveName 7 = Just SEC_t233r1+toCurveName 8 = Just SEC_t239k1+toCurveName 9 = Just SEC_t283k1+toCurveName 10 = Just SEC_t283r1+toCurveName 11 = Just SEC_t409k1+toCurveName 12 = Just SEC_t409r1+toCurveName 13 = Just SEC_t571k1+toCurveName 14 = Just SEC_t571r1+toCurveName 15 = Just SEC_p160k1+toCurveName 16 = Just SEC_p160r1+toCurveName 17 = Just SEC_p160r2+toCurveName 18 = Just SEC_p192k1+toCurveName 19 = Just SEC_p192r1+toCurveName 20 = Just SEC_p224k1+toCurveName 21 = Just SEC_p224r1+toCurveName 22 = Just SEC_p256k1+toCurveName 23 = Just SEC_p256r1+toCurveName 24 = Just SEC_p384r1+toCurveName 25 = Just SEC_p521r1+toCurveName _ = Nothing++fromCurveName :: CurveName -> Maybe Word16+fromCurveName SEC_t163k1 = Just 1+fromCurveName SEC_t163r1 = Just 2+fromCurveName SEC_t163r2 = Just 3+fromCurveName SEC_t193r1 = Just 4+fromCurveName SEC_t193r2 = Just 5+fromCurveName SEC_t233k1 = Just 6+fromCurveName SEC_t233r1 = Just 7+fromCurveName SEC_t239k1 = Just 8+fromCurveName SEC_t283k1 = Just 9+fromCurveName SEC_t283r1 = Just 10+fromCurveName SEC_t409k1 = Just 11+fromCurveName SEC_t409r1 = Just 12+fromCurveName SEC_t571k1 = Just 13+fromCurveName SEC_t571r1 = Just 14+fromCurveName SEC_p160k1 = Just 15+fromCurveName SEC_p160r1 = Just 16+fromCurveName SEC_p160r2 = Just 17+fromCurveName SEC_p192k1 = Just 18+fromCurveName SEC_p192r1 = Just 19+fromCurveName SEC_p224k1 = Just 20+fromCurveName SEC_p224r1 = Just 21+fromCurveName SEC_p256k1 = Just 22+fromCurveName SEC_p256r1 = Just 23+fromCurveName SEC_p384r1 = Just 24+fromCurveName SEC_p521r1 = Just 25+fromCurveName _ = Nothing
Network/TLS/Extra/Cipher.hs view
@@ -33,6 +33,8 @@ , cipher_DHE_DSS_AES128_SHA1 , cipher_DHE_DSS_AES256_SHA1 , cipher_DHE_DSS_RC4_SHA1+ , cipher_DHE_RSA_AES128GCM_SHA256+ , cipher_ECDHE_RSA_AES128GCM_SHA256 ) where import qualified Data.ByteString as B@@ -65,6 +67,10 @@ aes256_cbc_encrypt = aes_cbc_encrypt aes256_cbc_decrypt = aes_cbc_decrypt +aes128_gcm_encrypt, aes128_gcm_decrypt :: Key -> Nonce -> B.ByteString -> AdditionalData -> (B.ByteString, T.AuthTag)+aes128_gcm_encrypt key nonce d ad = AES.encryptGCM (AES.initAES key) nonce ad d+aes128_gcm_decrypt key nonce d ad = AES.decryptGCM (AES.initAES key) nonce ad d+ tripledes_ede_cbc_encrypt :: Key -> IV -> B.ByteString -> B.ByteString tripledes_ede_cbc_encrypt key iv bs = cbcEncrypt (cipherInit $ tripledes_key key) (tripledes_iv iv) bs@@ -106,6 +112,7 @@ , cipher_AES128_SHA1, cipher_AES256_SHA1 , cipher_DHE_DSS_RC4_SHA1, cipher_RC4_128_SHA1, cipher_RC4_128_MD5 , cipher_RSA_3DES_EDE_CBC_SHA1+ , cipher_DHE_RSA_AES128GCM_SHA256 ] -- | list of medium ciphers.@@ -119,7 +126,8 @@ -- | DHE-RSA cipher suite ciphersuite_dhe_rsa :: [Cipher] ciphersuite_dhe_rsa = [cipher_DHE_RSA_AES256_SHA256, cipher_DHE_RSA_AES128_SHA256- , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1]+ , cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA1+ , cipher_DHE_RSA_AES128GCM_SHA256] ciphersuite_dhe_dss :: [Cipher] ciphersuite_dhe_dss = [cipher_DHE_DSS_AES256_SHA1, cipher_DHE_DSS_AES128_SHA1, cipher_DHE_DSS_RC4_SHA1]@@ -128,7 +136,7 @@ ciphersuite_unencrypted :: [Cipher] ciphersuite_unencrypted = [cipher_null_MD5, cipher_null_SHA1] -bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede :: Bulk+bulk_null, bulk_rc4, bulk_aes128, bulk_aes256, bulk_tripledes_ede, bulk_aes128gcm :: Bulk bulk_null = Bulk { bulkName = "null" , bulkKeySize = 0@@ -154,6 +162,14 @@ , bulkF = BulkBlockF aes128_cbc_encrypt aes128_cbc_decrypt } +bulk_aes128gcm = Bulk+ { bulkName = "AES128GCM"+ , bulkKeySize = 16 -- RFC 5116 Sec 5.1: K_LEN+ , bulkIVSize = 4 -- RFC 5288 GCMNonce.salt, fixed_iv_length+ , bulkBlockSize = 0 -- dummy, not used+ , bulkF = BulkAeadF aes128_gcm_encrypt aes128_gcm_decrypt+ }+ bulk_aes256 = Bulk { bulkName = "AES256" , bulkKeySize = 32@@ -348,6 +364,25 @@ , cipherMinVer = Nothing } +cipher_DHE_RSA_AES128GCM_SHA256 :: Cipher+cipher_DHE_RSA_AES128GCM_SHA256 = Cipher+ { cipherID = 0x9e+ , cipherName = "DHE-RSA-AES128GCM-SHA256"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = hash_sha256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++cipher_ECDHE_RSA_AES128GCM_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128GCM_SHA256 = Cipher+ { cipherID = 0xc02f+ , cipherName = "ECDHE-RSA-AES128GCM-SHA256"+ , cipherBulk = bulk_aes128gcm+ , cipherHash = hash_sha256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ } {- TLS 1.0 ciphers definition
Network/TLS/Handshake/Client.hs view
@@ -63,7 +63,18 @@ handshakeTerminate ctx where ciphers = ctxCiphers ctx compressions = supportedCompressions $ ctxSupported ctx- getExtensions = sequence [sniExtension,secureReneg,npnExtention] >>= return . catMaybes+ getExtensions = sequence [sniExtension+ ,secureReneg+ ,npnExtention+ ,alpnExtension+ {-+ ,curveExtension,+ ,ecPointExtension+ ,sessionTicketExtension+ ,heartbeatExtension+ -}+ ,signatureAlgExtension+ ] toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = (extensionID ext, extensionEncode ext)@@ -75,14 +86,33 @@ npnExtention = if isJust $ onNPNServerSuggest $ clientHooks cparams then return $ Just $ toExtensionRaw $ NextProtocolNegotiation [] else return Nothing+ alpnExtension = do+ mprotos <- onSuggestALPN $ clientHooks cparams+ case mprotos of+ Nothing -> return Nothing+ Just protos -> do+ usingState_ ctx $ setClientALPNSuggest protos+ return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos sniExtension = if clientUseServerNameIndication cparams then return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName $ fst $ clientServerIdentification cparams] else return Nothing++ {-+ curveExtension = return $ Just $ toExtensionRaw $ EllipticCurvesSupported [NamedCurve_secp256k1,NamedCurve_secp256r1]+ ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]++ sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket++ heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend+ -}++ signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams+ sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom let clientSession = Session . maybe Nothing (Just . fst) $ clientWantSessionResume cparams highestVer = maximum $ supportedVersions $ ctxSupported ctx- extensions <- getExtensions+ extensions <- catMaybes <$> getExtensions startHandshake ctx highestVer crand usingState_ ctx $ setVersionIfUnset highestVer sendPacket ctx $ Handshake@@ -174,6 +204,7 @@ return $ CKX_RSA encryptedPreMaster CipherKeyExchange_DHE_RSA -> getCKX_DHE CipherKeyExchange_DHE_DSS -> getCKX_DHE+ CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) sendPacket ctx $ Handshake [ClientKeyXchg ckx] where getCKX_DHE = do@@ -186,6 +217,17 @@ return $ CKX_DH clientDHPub + getCKX_ECDHE = do+ xver <- usingState_ ctx getVersion+ (ServerECDHParams ecdhparams serverECDHPub) <- fromJust <$> usingHState ctx (gets hstServerECDHParams)+ (clientECDHPriv, clientECDHPub) <- generateECDHE ctx ecdhparams++ case ecdhGetShared ecdhparams clientECDHPriv serverECDHPub of+ Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)+ Just premaster -> do+ usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster+ return $ CKX_ECDH clientECDHPub+ -- In order to send a proper certificate verify message, -- we have to do the following: --@@ -275,10 +317,22 @@ setVersion rver usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg + case extensionDecode False `fmap` (lookup extensionID_ApplicationLayerProtocolNegotiation exts) of+ Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do+ mprotos <- getClientALPNSuggest+ case mprotos of+ Just protos -> when (elem proto protos) $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ _ -> return ()+ _ -> return ()+ case extensionDecode False `fmap` (lookup extensionID_NextProtocolNegotiation exts) of Just (Just (NextProtocolNegotiation protos)) -> usingState_ ctx $ do- setExtensionNPN True- setServerNextProtocolSuggest protos+ alpnDone <- getExtensionALPN+ unless alpnDone $ do+ setExtensionNPN True+ setServerNextProtocolSuggest protos _ -> return () case resumingSession of@@ -324,6 +378,8 @@ doDHESignature dhparams signature SignatureRSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> do doDHESignature dhparams signature SignatureDSS+ (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> do+ doECDHESignature ecdhparams signature SignatureRSA (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of@@ -337,6 +393,13 @@ verified <- signatureVerify ctx signatureType expectedData signature when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for dhparams", True, HandshakeFailure) usingHState ctx $ setServerDHParams dhparams++ doECDHESignature ecdhparams signature signatureType = do+ -- TODO verify DHParams+ expectedData <- generateSignedECDHParams ctx ecdhparams+ verified <- signatureVerify ctx signatureType expectedData signature+ when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " for dhparams", True, HandshakeFailure)+ usingHState ctx $ setServerECDHParams ecdhparams processServerKeyExchange ctx p = processCertificateRequest ctx p
Network/TLS/Handshake/Key.hs view
@@ -13,6 +13,7 @@ , decryptRSA , verifyRSA , generateDHE+ , generateECDHE ) where import Data.ByteString (ByteString)@@ -60,3 +61,6 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ \rng -> dhGenerateKeyPair rng dhp++generateECDHE :: Context -> ECDHParams -> IO (ECDHPrivate, ECDHPublic)+generateECDHE ctx dhp = usingState_ ctx $ withRNG $ \rng -> ecdhGenerateKeyPair rng dhp
Network/TLS/Handshake/Process.hs view
@@ -93,6 +93,17 @@ let premaster = dhGetShared dhparams dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster +processClientKeyXchg ctx (CKX_ECDH clientECDHValue) = do+ 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)+ case ecdhGetShared ecdhparams ecdhpriv clientECDHValue of+ Nothing -> throwCore $ Error_Protocol("invalid client public key", True, HandshakeFailure)+ Just premaster ->+ usingHState ctx $ setMasterSecretFromPre rver role premaster+ processClientFinished :: Context -> FinishedData -> IO () processClientFinished ctx fdata = do (cc,ver) <- usingState_ ctx $ (,) <$> isClientContext <*> getVersion
Network/TLS/Handshake/Server.hs view
@@ -18,6 +18,7 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials+import Network.TLS.Crypto.ECDH import Network.TLS.Extension import Network.TLS.Util (catchException, fromJust) import Network.TLS.IO@@ -106,12 +107,27 @@ CipherKeyExchange_DH_Anon -> return $ Nothing CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning SignatureDSS creds+ CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning SignatureRSA creds _ -> throwCore $ Error_Protocol ("key exchange algorithm not implemented", True, HandshakeFailure) resumeSessionData <- case clientSession of (Session (Just clientSessionId)) -> liftIO $ sessionResume (sharedSessionManager $ ctxShared ctx) clientSessionId (Session Nothing) -> return Nothing + case extensionDecode False `fmap` (lookup extensionID_ApplicationLayerProtocolNegotiation exts) of+ Just (Just (ApplicationLayerProtocolNegotiation protos)) -> usingState_ ctx $ setClientALPNSuggest protos+ _ -> return ()++ case extensionDecode False `fmap` (lookup extensionID_EllipticCurves exts) of+ Just (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` (lookup extensionID_EcPointFormats exts) of+ Just (Just (EcPointFormatsSupported fs)) -> usingState_ ctx $ setClientEcPointFormatSuggest fs+ _ -> return ()+ doHandshake sparams cred ctx chosenVersion usedCipher usedCompression clientSession resumeSessionData exts where@@ -144,7 +160,39 @@ handshakeTerminate ctx where clientRequestedNPN = isJust $ lookup extensionID_NextProtocolNegotiation exts+ clientALPNSuggest = isJust $ lookup extensionID_ApplicationLayerProtocolNegotiation exts + applicationProtocol = do+ protos <- alpn+ if null protos then npn else return protos++ alpn | clientALPNSuggest = do+ suggest <- usingState_ ctx $ getClientALPNSuggest+ case (onALPNClientSuggest $ serverHooks sparams, suggest) of+ (Just io, Just protos) -> do+ proto <- liftIO $ io protos+ usingState_ ctx $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ return $ [ ( extensionID_ApplicationLayerProtocolNegotiation+ , extensionEncode $ ApplicationLayerProtocolNegotiation [proto]) ]+ (_, _) -> return []+ | otherwise = return []+ npn = do+ nextProtocols <-+ if clientRequestedNPN+ then liftIO $ onSuggestNextProtocols $ serverHooks sparams+ else return Nothing+ case nextProtocols of+ Just protos -> do+ usingState_ ctx $ do+ setExtensionNPN True+ setServerNextProtocolSuggest protos+ return [ ( extensionID_NextProtocolNegotiation+ , extensionEncode $ NextProtocolNegotiation protos) ]+ Nothing -> return []++ --- -- When the client sends a certificate, check whether -- it is acceptable for the application.@@ -167,17 +215,8 @@ return $ extensionEncode (SecureRenegotiation cvf $ Just svf) return [ (0xff01, vf) ] else return []- nextProtocols <-- if clientRequestedNPN- then liftIO $ onSuggestNextProtocols $ serverHooks sparams- else return Nothing- npnExt <- case nextProtocols of- Just protos -> do usingState_ ctx $ do setExtensionNPN True- setServerNextProtocolSuggest protos- return [ ( extensionID_NextProtocolNegotiation- , extensionEncode $ NextProtocolNegotiation protos) ]- Nothing -> return []- let extensions = secRengExt ++ npnExt+ protoExt <- applicationProtocol+ let extensions = secRengExt ++ protoExt usingState_ ctx (setVersion chosenVersion) usingHState ctx $ setServerHelloParameters chosenVersion srand usedCipher usedCompression return $ ServerHello chosenVersion srand session (cipherID usedCipher)@@ -198,6 +237,7 @@ CipherKeyExchange_DH_Anon -> Just <$> generateSKX_DH_Anon CipherKeyExchange_DHE_RSA -> Just <$> generateSKX_DHE SignatureRSA CipherKeyExchange_DHE_DSS -> Just <$> generateSKX_DHE SignatureDSS+ CipherKeyExchange_ECDHE_RSA -> Just <$> generateSKX_ECDHE SignatureRSA _ -> return Nothing maybe (return ()) (sendPacket ctx . Handshake . (:[]) . ServerKeyXchg) skx @@ -253,6 +293,39 @@ _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) generateSKX_DH_Anon = SKX_DH_Anon <$> setup_DHE++ setup_ECDHE curvename = do+ let ecdhparams = ecdhParams curvename+ (priv, pub) <- generateECDHE ctx ecdhparams++ let serverParams = ServerECDHParams ecdhparams pub++ usingHState ctx $ setServerECDHParams serverParams+ usingHState ctx $ modify $ \hst -> hst { hstECDHPrivate = Just priv }+ return (serverParams)++ generateSKX_ECDHE sigAlg = do+ 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+ signatureData <- generateSignedECDHParams ctx serverParams++ 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+ let hashDescr = signatureHashData sigAlg mhash+ signed <- signatureCreate ctx (fmap (\h -> (h, sigAlg)) mhash) hashDescr signatureData++ case sigAlg of+ SignatureRSA -> return $ SKX_ECDHE_RSA serverParams signed+ _ -> error ("generate skx_dhe unsupported signature type: " ++ show sigAlg) -- | receive Client data in handshake until the Finished handshake. --
Network/TLS/Handshake/Signature.hs view
@@ -14,13 +14,14 @@ , signatureVerify , signatureVerifyWithHashDescr , generateSignedDHParams+ , generateSignedECDHParams ) where import Crypto.PubKey.HashDescr import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Struct-import Network.TLS.Packet (generateCertificateVerify_SSL, encodeSignedDHParams)+import Network.TLS.Packet (generateCertificateVerify_SSL, encodeSignedDHParams, encodeSignedECDHParams) import Network.TLS.State import Network.TLS.Handshake.State import Network.TLS.Handshake.Key@@ -107,3 +108,9 @@ (cran, sran) <- usingHState ctx $ do (,) <$> gets hstClientRandom <*> (fromJust "server random" <$> gets hstServerRandom) return $ encodeSignedDHParams cran sran serverParams++generateSignedECDHParams :: Context -> ServerECDHParams -> IO Bytes+generateSignedECDHParams ctx serverParams = do+ (cran, sran) <- usingHState ctx $ do+ (,) <$> gets hstClientRandom <*> (fromJust "server random" <$> gets hstServerRandom)+ return $ encodeSignedECDHParams cran sran serverParams
Network/TLS/Handshake/State.hs view
@@ -20,6 +20,7 @@ , getLocalPrivateKey , getRemotePublicKey , setServerDHParams+ , setServerECDHParams -- * cert accessors , setClientCertSent , getClientCertSent@@ -67,6 +68,8 @@ , hstKeyState :: !HandshakeKeyState , hstServerDHParams :: !(Maybe ServerDHParams) , hstDHPrivate :: !(Maybe DHPrivate)+ , hstServerECDHParams :: !(Maybe ServerECDHParams)+ , hstECDHPrivate :: !(Maybe ECDHPrivate) , hstHandshakeDigest :: !(Either [Bytes] HashCtx) , hstHandshakeMessages :: [Bytes] , hstClientCertRequest :: !(Maybe ClientCertRequestData) -- ^ Set to Just-value when certificate request was received@@ -103,6 +106,8 @@ , hstKeyState = HandshakeKeyState Nothing Nothing , hstServerDHParams = Nothing , hstDHPrivate = Nothing+ , hstServerECDHParams = Nothing+ , hstECDHPrivate = Nothing , hstHandshakeDigest = Left [] , hstHandshakeMessages = [] , hstClientCertRequest = Nothing@@ -135,6 +140,9 @@ setServerDHParams :: ServerDHParams -> HandshakeM () setServerDHParams shp = modify (\hst -> hst { hstServerDHParams = Just shp }) +setServerECDHParams :: ServerECDHParams -> HandshakeM ()+setServerECDHParams shp = modify (\hst -> hst { hstServerECDHParams = Just shp })+ setCertReqSent :: Bool -> HandshakeM () setCertReqSent b = modify (\hst -> hst { hstCertReqSent = b }) @@ -213,7 +221,8 @@ keyblockSize = cipherKeyBlockSize cipher bulk = cipherBulk cipher- digestSize = hashSize $ cipherHash cipher+ digestSize = if hasMAC (bulkF bulk) then hashSize (cipherHash cipher)+ else 0 keySize = bulkKeySize bulk ivSize = bulkIVSize bulk kb = generateKeyBlock ver (hstClientRandom hst)
Network/TLS/Packet.hs view
@@ -41,6 +41,7 @@ , decodePreMasterSecret , encodePreMasterSecret , encodeSignedDHParams+ , encodeSignedECDHParams , decodeReallyServerKeyXchgAlgorithmData @@ -51,6 +52,10 @@ , generateServerFinished , generateCertificateVerify_SSL++ -- * for extensions parsing+ , getSignatureHashAlgorithm+ , putSignatureHashAlgorithm ) where import Network.TLS.Struct@@ -67,6 +72,7 @@ import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..))+import Network.TLS.Util.Serialization (os2ip,i2ospOf_) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC@@ -287,12 +293,25 @@ parseCKE CipherKeyExchange_DHE_RSA = parseClientDHPublic parseCKE CipherKeyExchange_DHE_DSS = parseClientDHPublic parseCKE CipherKeyExchange_DH_Anon = parseClientDHPublic+ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE _ = error "unsupported client key exchange type" parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16+ parseClientECDHPublic = do+ len <- getWord8+ _ <- getWord8 -- Magic number 4+ let siz = fromIntegral len `div` 2+ xb <- getBytes siz+ yb <- getBytes siz+ let x = os2ip xb+ y = os2ip yb+ return $ CKX_ECDH $ ecdhPublic x y siz decodeServerKeyXchg_DH :: Get ServerDHParams decodeServerKeyXchg_DH = getServerDHParams +-- We don't support ECDH_Anon at this moment+-- decodeServerKeyXchg_ECDH :: Get ServerECDHParams+ decodeServerKeyXchg_RSA :: Get ServerRSAParams decodeServerKeyXchg_RSA = ServerRSAParams <$> getInteger16 -- modulus <*> getInteger16 -- exponent@@ -312,6 +331,10 @@ dhparams <- getServerDHParams signature <- getDigitallySigned ver return $ SKX_DHE_DSS dhparams signature+ CipherKeyExchange_ECDHE_RSA -> do+ dhparams <- getServerECDHParams+ signature <- getDigitallySigned ver+ return $ SKX_ECDHE_RSA dhparams signature _ -> do bs <- remaining >>= getBytes return $ SKX_Unknown bs@@ -362,6 +385,11 @@ case ckx of CKX_RSA encryptedPreMaster -> putBytes encryptedPreMaster CKX_DH clientDHPublic -> putInteger16 $ dhUnwrapPublic clientDHPublic+ CKX_ECDH clientECDHPublic -> do+ let (x,y,siz) = ecdhUnwrapPublic clientECDHPublic+ let xb = i2ospOf_ siz x+ yb = i2ospOf_ siz y+ putOpaque8 $ B.concat [B.singleton 4,xb,yb] encodeHandshakeContent (ServerKeyXchg skg) = case skg of@@ -369,6 +397,7 @@ SKX_DH_Anon params -> putServerDHParams params SKX_DHE_RSA params sig -> putServerDHParams params >> putDigitallySigned sig SKX_DHE_DSS params sig -> putServerDHParams params >> putDigitallySigned sig+ SKX_ECDHE_RSA params sig -> putServerECDHParams params >> putDigitallySigned sig SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) @@ -466,6 +495,27 @@ putServerDHParams (ServerDHParams dhparams dhpub) = mapM_ putInteger16 $ dhUnwrap dhparams dhpub +getServerECDHParams :: Get ServerECDHParams+getServerECDHParams = do+ _ <- getWord8 -- ECParameters ECCurveType: curve name type, should be 3+ w16 <- getWord16 -- ECParameters NamedCurve+ mxy <- getOpaque16 -- ECPoint+ let xy = B.drop 1 mxy+ siz = B.length xy `div` 2+ (xb,yb) = B.splitAt siz xy+ x = os2ip xb+ y = os2ip yb+ return $ ServerECDHParams (ecdhParams w16) (ecdhPublic x y siz)++putServerECDHParams :: ServerECDHParams -> Put+putServerECDHParams (ServerECDHParams ecdhparams ecdhpub) = do+ let (w16,x,y,siz) = ecdhUnwrap ecdhparams ecdhpub+ putWord8 3 -- ECParameters ECCurveType: curve name type+ putWord16 w16 -- ECParameters NamedCurve+ let xb = i2ospOf_ siz x+ yb = i2ospOf_ siz y+ putOpaque8 $ B.concat [B.singleton 4,xb,yb] -- ECPoint+ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned ver | ver >= TLS12 = DigitallySigned <$> (Just <$> getSignatureHashAlgorithm)@@ -582,3 +632,10 @@ encodeSignedDHParams :: ClientRandom -> ServerRandom -> ServerDHParams -> Bytes encodeSignedDHParams cran sran dhparams = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerDHParams dhparams++-- Combination of RFC 5246 and 4492 is ambiguous.+-- Let's assume ecdhe_rsa and ecdhe_dss are identical to+-- dhe_rsa and dhe_dss.+encodeSignedECDHParams :: ClientRandom -> ServerRandom -> ServerECDHParams -> Bytes+encodeSignedECDHParams cran sran dhparams = runPut $+ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams
Network/TLS/Parameters.hs view
@@ -126,7 +126,7 @@ defaultSupported :: Supported defaultSupported = Supported- { supportedVersions = [TLS12,TLS11,TLS10,SSL3]+ { supportedVersions = [TLS12,TLS11,TLS10] , supportedCiphers = [] , supportedCompressions = [nullCompression] , supportedHashSignatures = [ (Struct.HashSHA512, SignatureRSA)@@ -185,6 +185,7 @@ [DistinguishedName]) -> IO (Maybe (CertificateChain, PrivKey)) , onNPNServerSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) , onServerCertificate :: CertificateStore -> ValidationCache -> ServiceID -> CertificateChain -> IO [FailedReason]+ , onSuggestALPN :: IO (Maybe [B.ByteString]) } defaultClientHooks :: ClientHooks@@ -192,6 +193,7 @@ { onCertificateRequest = \ _ -> return Nothing , onNPNServerSuggest = Nothing , onServerCertificate = validateDefault+ , onSuggestALPN = return Nothing } instance Show ClientHooks where@@ -226,6 +228,7 @@ , onSuggestNextProtocols :: IO (Maybe [B.ByteString]) -- | at each new handshake, we call this hook to see if we allow handshake to happens. , onNewHandshake :: Measurement -> IO Bool+ , onALPNClientSuggest :: Maybe ([B.ByteString] -> IO B.ByteString) } defaultServerHooks :: ServerHooks@@ -235,6 +238,7 @@ , onUnverifiedClientCert = return False , onSuggestNextProtocols = return Nothing , onNewHandshake = \_ -> return True+ , onALPNClientSuggest = Nothing } instance Show ServerHooks where
Network/TLS/Record/Disengage.hs view
@@ -16,6 +16,7 @@ import Control.Monad.State +import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Struct import Network.TLS.ErrT import Network.TLS.Cap@@ -24,6 +25,8 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Util+import Network.TLS.Wire+import Network.TLS.Packet import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -111,6 +114,22 @@ , cipherDataMAC = Just mac , cipherDataPadding = Nothing }++ decryptOf (BulkAeadF _ decryptF) = do+ let authtaglen = 16 -- FIXME: fixed_iv_length + record_iv_length+ nonceexplen = 8 -- FIXME: record_iv_length+ econtentlen = B.length econtent - authtaglen - nonceexplen+ (enonce, econtent', authTag) <- get3 econtent (nonceexplen, econtentlen, authtaglen)+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tst+ Header typ v _ = recordToHeader record+ hdr = Header typ v $ fromIntegral econtentlen+ ad = B.concat [ encodedSeq, encodeHeader hdr ]+ nonce = cstIV (stCryptState tst) `B.append` enonce+ (content, authTag2) = decryptF writekey nonce econtent' ad+ when (AuthTag authTag /= authTag2) $+ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)+ modify incrRecordState+ return content get3 s ls = maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls get2 s (d1,d2) = get3 s (d1,d2,0) >>= \(r1,r2,_) -> return (r1,r2)
Network/TLS/Record/Engage.hs view
@@ -13,6 +13,7 @@ ) where import Control.Monad.State+import Crypto.Cipher.Types (AuthTag(..)) import Network.TLS.Cap import Network.TLS.Record.State@@ -20,6 +21,8 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Util+import Network.TLS.Wire+import Network.TLS.Packet import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -44,13 +47,7 @@ encryptContent :: Record Compressed -> ByteString -> RecordM ByteString encryptContent record content = do- digest <- makeDigest (recordToHeader record) content- encryptData $ B.concat [content, digest]--encryptData :: ByteString -> RecordM ByteString-encryptData content = do tstate <- get- ver <- getRecordVersion let cipher = fromJust "cipher" $ stCipher tstate let bulk = cipherBulk cipher@@ -59,26 +56,60 @@ let writekey = cstKey cst case bulkF bulk of- BulkBlockF encrypt _ -> do- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding = if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize) in- let padbyte' = if padbyte == 0 then blockSize else padbyte in- B.replicate padbyte' (fromIntegral (padbyte' - 1))- else- B.empty-- let e = encrypt writekey (cstIV cst) (B.concat [ content, padding ])- if hasExplicitBlockIV ver- then return $ B.concat [cstIV cst,e]- else do- let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e- put $ tstate { stCryptState = cst { cstIV = newiv } }- return e+ BulkBlockF encryptF _ -> do+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptBlock encryptF writekey content' cst tstate bulk BulkStreamF initF encryptF _ -> do- let iv = cstIV cst- let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content+ digest <- makeDigest (recordToHeader record) content+ let content' = B.concat [content, digest]+ encryptStream encryptF writekey content' cst tstate initF+ BulkAeadF encryptF _ ->+ encryptAead encryptF writekey content cst tstate record++encryptBlock :: (Key -> IV -> ByteString -> ByteString)+ -> Key -> ByteString -> CryptState -> RecordState -> Bulk+ -> RecordM ByteString+encryptBlock encryptF writekey content cst tstate bulk = do+ ver <- getRecordVersion+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding = if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize) in+ let padbyte' = if padbyte == 0 then blockSize else padbyte in B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else+ B.empty++ let iv = cstIV cst+ e = encryptF writekey iv $ B.concat [ content, padding ]+ if hasExplicitBlockIV ver+ then return $ B.concat [iv,e]+ else do+ let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e put $ tstate { stCryptState = cst { cstIV = newiv } } return e++encryptStream :: (IV -> ByteString -> (ByteString, IV))+ -> Key -> ByteString -> CryptState -> RecordState -> (Key -> IV)+ -> RecordM ByteString+encryptStream encryptF writekey content cst tstate initF = do+ let iv = cstIV cst+ let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content+ put $ tstate { stCryptState = cst { cstIV = newiv } }+ return e++encryptAead :: (Key -> Nonce -> ByteString -> AdditionalData -> (ByteString, AuthTag))+ -> Key -> ByteString -> CryptState -> RecordState -> Record Compressed+ -> RecordM ByteString+encryptAead encryptF writekey content cst tstate record = do+ let encodedSeq = encodeWord64 $ msSequence $ stMacState tstate+ hdr = recordToHeader record+ ad = B.concat [ encodedSeq, encodeHeader hdr ]+ let salt = cstIV cst+ processorNum = encodeWord32 1 -- FIXME+ counter = B.drop 4 encodedSeq -- FIXME: probably OK+ nonce = B.concat [salt, processorNum, counter]+ let (e, AuthTag authtag) = encryptF writekey nonce content ad+ modify incrRecordState+ return $ B.concat [processorNum, counter, e, authtag]
Network/TLS/Record/State.hs view
@@ -13,6 +13,7 @@ , MacState(..) , RecordState(..) , newRecordState+ , incrRecordState , RecordM , runRecordM , getRecordVersion
Network/TLS/Sending.hs view
@@ -72,7 +72,9 @@ txState <- readMVar $ ctxTxState ctx let sz = case stCipher $ txState of Nothing -> 0- Just cipher -> bulkIVSize $ cipherBulk cipher+ Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher+ then bulkIVSize $ cipherBulk cipher+ else 0 -- to not generate IV if hasExplicitBlockIV ver && sz > 0 then do newIV <- getStateRNG ctx sz runTxState ctx (modify (setRecordIV newIV) >> f)
Network/TLS/State.hs view
@@ -31,10 +31,18 @@ , getSecureRenegotiation , setExtensionNPN , getExtensionNPN+ , setExtensionALPN+ , getExtensionALPN , setNegotiatedProtocol , getNegotiatedProtocol , setServerNextProtocolSuggest , getServerNextProtocolSuggest+ , setClientALPNSuggest+ , getClientALPNSuggest+ , setClientEllipticCurveSuggest+ , getClientEllipticCurveSuggest+ , setClientEcPointFormatSuggest+ , getClientEcPointFormatSuggest , getClientCertificateChain , setClientCertificateChain , getVerifiedData@@ -52,6 +60,7 @@ import Network.TLS.RNG import Network.TLS.Types (Role(..)) import Network.TLS.Wire (GetContinuation)+import Network.TLS.Extension import qualified Data.ByteString as B import Control.Monad.State import Network.TLS.ErrT@@ -65,9 +74,13 @@ , stClientVerifiedData :: Bytes -- RFC 5746 , stServerVerifiedData :: Bytes -- RFC 5746 , stExtensionNPN :: Bool -- NPN draft extension+ , stExtensionALPN :: Bool -- RFC 7301 , stHandshakeRecordCont :: Maybe (GetContinuation (HandshakeType, Bytes))- , stNegotiatedProtocol :: Maybe B.ByteString -- NPN protocol+ , stNegotiatedProtocol :: Maybe B.ByteString -- NPN and ALPN protocol , stServerNextProtocolSuggest :: Maybe [B.ByteString]+ , stClientALPNSuggest :: Maybe [B.ByteString]+ , stClientEllipticCurveSuggest :: Maybe [NamedCurve]+ , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] , stClientCertificateChain :: Maybe CertificateChain , stRandomGen :: StateRNG , stVersion :: Maybe Version@@ -95,9 +108,13 @@ , stClientVerifiedData = B.empty , stServerVerifiedData = B.empty , stExtensionNPN = False+ , stExtensionALPN = False , stHandshakeRecordCont = Nothing , stNegotiatedProtocol = Nothing , stServerNextProtocolSuggest = Nothing+ , stClientALPNSuggest = Nothing+ , stClientEllipticCurveSuggest = Nothing+ , stClientEcPointFormatSuggest = Nothing , stClientCertificateChain = Nothing , stRandomGen = StateRNG rng , stVersion = Nothing@@ -179,6 +196,12 @@ getExtensionNPN :: TLSSt Bool getExtensionNPN = gets stExtensionNPN +setExtensionALPN :: Bool -> TLSSt ()+setExtensionALPN b = modify (\st -> st { stExtensionALPN = b })++getExtensionALPN :: TLSSt Bool+getExtensionALPN = gets stExtensionALPN+ setNegotiatedProtocol :: B.ByteString -> TLSSt () setNegotiatedProtocol s = modify (\st -> st { stNegotiatedProtocol = Just s }) @@ -190,6 +213,24 @@ getServerNextProtocolSuggest :: TLSSt (Maybe [B.ByteString]) getServerNextProtocolSuggest = gets stServerNextProtocolSuggest++setClientALPNSuggest :: [B.ByteString] -> TLSSt ()+setClientALPNSuggest ps = modify (\st -> st { stClientALPNSuggest = Just ps})++getClientALPNSuggest :: TLSSt (Maybe [B.ByteString])+getClientALPNSuggest = gets stClientALPNSuggest++setClientEllipticCurveSuggest :: [NamedCurve] -> TLSSt ()+setClientEllipticCurveSuggest nc = modify (\st -> st { stClientEllipticCurveSuggest = Just nc})++getClientEllipticCurveSuggest :: TLSSt (Maybe [NamedCurve])+getClientEllipticCurveSuggest = gets stClientEllipticCurveSuggest++setClientEcPointFormatSuggest :: [EcPointFormat] -> TLSSt ()+setClientEcPointFormatSuggest epf = modify (\st -> st { stClientEcPointFormatSuggest = Just epf})++getClientEcPointFormatSuggest :: TLSSt (Maybe [EcPointFormat])+getClientEcPointFormatSuggest = gets stClientEcPointFormatSuggest setClientCertificateChain :: CertificateChain -> TLSSt () setClientCertificateChain s = modify (\st -> st { stClientCertificateChain = Just s })
Network/TLS/Struct.hs view
@@ -28,6 +28,7 @@ , TLSException(..) , DistinguishedName , ServerDHParams(..)+ , ServerECDHParams(..) , ServerRSAParams(..) , ServerKeyXchgAlgorithmData(..) , ClientKeyXchgAlgorithmData(..)@@ -48,6 +49,8 @@ , numericalVer , verOfNum , TypeValuable, valOfType, valToType+ , EnumSafe8(..)+ , EnumSafe16(..) , packetType , typeOfHandshake ) where@@ -60,6 +63,7 @@ import Control.Exception (Exception(..)) import Network.TLS.Types import Network.TLS.Crypto.DH+import Network.TLS.Crypto.ECDH #if MIN_VERSION_mtl(2,2,1) #else import Control.Monad.Error@@ -233,6 +237,9 @@ data ServerDHParams = ServerDHParams DHParams {- (p,g) -} DHPublic {- y -} deriving (Show,Eq) +data ServerECDHParams = ServerECDHParams ECDHParams ECDHPublic+ deriving (Show,Eq)+ data ServerRSAParams = ServerRSAParams { rsa_modulus :: Integer , rsa_exponent :: Integer@@ -242,6 +249,7 @@ SKX_DH_Anon ServerDHParams | SKX_DHE_DSS ServerDHParams DigitallySigned | SKX_DHE_RSA ServerDHParams DigitallySigned+ | SKX_ECDHE_RSA ServerECDHParams DigitallySigned | SKX_RSA (Maybe ServerRSAParams) | SKX_DH_DSS (Maybe ServerRSAParams) | SKX_DH_RSA (Maybe ServerRSAParams)@@ -252,6 +260,7 @@ data ClientKeyXchgAlgorithmData = CKX_RSA Bytes | CKX_DH DHPublic+ | CKX_ECDH ECDHPublic deriving (Show,Eq) type DeprecatedRecord = ByteString@@ -307,6 +316,15 @@ class TypeValuable a where valOfType :: a -> Word8 valToType :: Word8 -> Maybe a++-- a better name for TypeValuable+class EnumSafe8 a where+ fromEnumSafe8 :: a -> Word8+ toEnumSafe8 :: Word8 -> Maybe a++class EnumSafe16 a where+ fromEnumSafe16 :: a -> Word16+ toEnumSafe16 :: Word16 -> Maybe a instance TypeValuable ConnectionEnd where valOfType ConnectionServer = 0
Network/TLS/Util/Serialization.hs view
@@ -1,6 +1,8 @@ module Network.TLS.Util.Serialization ( os2ip , i2osp+ , i2ospOf_+ , lengthBytes ) where -import Crypto.Number.Serialize (os2ip, i2osp)+import Crypto.Number.Serialize (os2ip, i2osp, i2ospOf_, lengthBytes)
Network/TLS/Wire.hs view
@@ -43,6 +43,7 @@ , putOpaque24 , putInteger16 , encodeWord16+ , encodeWord32 , encodeWord64 ) where @@ -131,6 +132,9 @@ putWord16 :: Word16 -> Put putWord16 = putWord16be +putWord32 :: Word32 -> Put+putWord32 = putWord32be+ putWords16 :: [Word16] -> Put putWords16 l = do putWord16 $ 2 * (fromIntegral $ length l)@@ -160,6 +164,9 @@ encodeWord16 :: Word16 -> Bytes encodeWord16 = runPut . putWord16++encodeWord32 :: Word32 -> Bytes+encodeWord32 = runPut . putWord32 encodeWord64 :: Word64 -> Bytes encodeWord64 = runPut . putWord64be
Tests/Ciphers.hs view
@@ -19,20 +19,25 @@ arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (fromIntegral $ bulkBlockSize bulk) -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString+data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString deriving (Show,Eq) instance Arbitrary BulkTest where arbitrary = do bulk <- cipherBulk `fmap` elements ciphersuite_all- BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk+ BulkTest bulk <$> arbitraryKey bulk <*> arbitraryIV bulk <*> arbitraryText bulk <*> arbitraryText bulk propertyBulkFunctional :: BulkTest -> Bool-propertyBulkFunctional (BulkTest bulk key iv t) =+propertyBulkFunctional (BulkTest bulk key iv t additional) = case bulkF bulk of BulkBlockF enc dec -> block enc dec BulkStreamF ktoi enc dec -> stream ktoi enc dec+ BulkAeadF enc dec -> aead enc dec where block e d = (d key iv . e key iv) t == t stream ktoi e d = (fst . d siv . fst . e siv) t == t where siv = ktoi key+ aead e d =+ let (encrypted, at) = e key iv t additional+ (decrypted, at2) = d key iv encrypted additional+ in decrypted == t && at == at2
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.2.13+Version: 1.2.14 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -8,7 +8,7 @@ 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 Diffie Hellman key exchanges,+ 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@@ -45,7 +45,7 @@ , crypto-random >= 0.0 && < 0.1 , crypto-numbers , crypto-cipher-types >= 0.0.8- , crypto-pubkey >= 0.2.4+ , crypto-pubkey >= 0.2.8 , crypto-pubkey-types >= 0.4 , cipher-rc4 , cipher-des@@ -72,8 +72,10 @@ 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