diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Network/TLS/Cipher.hs b/Network/TLS/Cipher.hs --- a/Network/TLS/Cipher.hs +++ b/Network/TLS/Cipher.hs @@ -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 diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -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 diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -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 diff --git a/Network/TLS/Crypto/ECDH.hs b/Network/TLS/Crypto/ECDH.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Crypto/ECDH.hs @@ -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 diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -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 +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)) diff --git a/Network/TLS/Extension/EC.hs b/Network/TLS/Extension/EC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extension/EC.hs @@ -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 diff --git a/Network/TLS/Extra/Cipher.hs b/Network/TLS/Extra/Cipher.hs --- a/Network/TLS/Extra/Cipher.hs +++ b/Network/TLS/Extra/Cipher.hs @@ -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 diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -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 diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -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 diff --git a/Network/TLS/Handshake/Process.hs b/Network/TLS/Handshake/Process.hs --- a/Network/TLS/Handshake/Process.hs +++ b/Network/TLS/Handshake/Process.hs @@ -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 diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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. -- diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -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 diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -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) diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -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 diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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 diff --git a/Network/TLS/Record/Disengage.hs b/Network/TLS/Record/Disengage.hs --- a/Network/TLS/Record/Disengage.hs +++ b/Network/TLS/Record/Disengage.hs @@ -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) diff --git a/Network/TLS/Record/Engage.hs b/Network/TLS/Record/Engage.hs --- a/Network/TLS/Record/Engage.hs +++ b/Network/TLS/Record/Engage.hs @@ -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] diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -13,6 +13,7 @@ , MacState(..) , RecordState(..) , newRecordState + , incrRecordState , RecordM , runRecordM , getRecordVersion diff --git a/Network/TLS/Sending.hs b/Network/TLS/Sending.hs --- a/Network/TLS/Sending.hs +++ b/Network/TLS/Sending.hs @@ -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) diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -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 }) diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -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 diff --git a/Network/TLS/Util/Serialization.hs b/Network/TLS/Util/Serialization.hs --- a/Network/TLS/Util/Serialization.hs +++ b/Network/TLS/Util/Serialization.hs @@ -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) diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -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 diff --git a/Tests/Ciphers.hs b/Tests/Ciphers.hs --- a/Tests/Ciphers.hs +++ b/Tests/Ciphers.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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