tls 1.4.0 → 1.4.1
raw patch · 47 files changed
+514/−325 lines, 47 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +8/−0
- Network/TLS.hs +3/−1
- Network/TLS/Backend.hs +3/−4
- Network/TLS/Cipher.hs +1/−1
- Network/TLS/Compression.hs +2/−3
- Network/TLS/Context.hs +2/−2
- Network/TLS/Context/Internal.hs +2/−2
- Network/TLS/Core.hs +4/−3
- Network/TLS/Credentials.hs +10/−5
- Network/TLS/Crypto.hs +18/−8
- Network/TLS/Crypto/DH.hs +9/−1
- Network/TLS/Crypto/IES.hs +105/−24
- Network/TLS/Crypto/Types.hs +7/−1
- Network/TLS/Extension.hs +11/−23
- Network/TLS/Extra/Cipher.hs +3/−2
- Network/TLS/Handshake.hs +9/−5
- Network/TLS/Handshake/Client.hs +57/−44
- Network/TLS/Handshake/Common.hs +5/−6
- Network/TLS/Handshake/Key.hs +9/−1
- Network/TLS/Handshake/Process.hs +5/−2
- Network/TLS/Handshake/Server.hs +56/−60
- Network/TLS/Handshake/Signature.hs +2/−2
- Network/TLS/Handshake/State.hs +3/−4
- Network/TLS/Hooks.hs +5/−5
- Network/TLS/IO.hs +3/−3
- Network/TLS/Imports.hs +48/−11
- Network/TLS/MAC.hs +1/−2
- Network/TLS/Measurement.hs +1/−1
- Network/TLS/Packet.hs +17/−17
- Network/TLS/Parameters.hs +37/−13
- Network/TLS/Receiving.hs +5/−4
- Network/TLS/Record/Disengage.hs +7/−7
- Network/TLS/Record/Engage.hs +1/−2
- Network/TLS/Record/State.hs +1/−3
- Network/TLS/Record/Types.hs +1/−2
- Network/TLS/Sending.hs +3/−4
- Network/TLS/State.hs +2/−3
- Network/TLS/Struct.hs +10/−12
- Network/TLS/Types.hs +1/−2
- Network/TLS/Util.hs +1/−3
- Network/TLS/Util/ASN1.hs +1/−1
- Network/TLS/Wire.hs +4/−8
- Network/TLS/X509.hs +3/−3
- Tests/Ciphers.hs +3/−3
- Tests/Connection.hs +15/−9
- Tests/Tests.hs +9/−2
- tls.cabal +1/−1
CHANGELOG.md view
@@ -1,3 +1,11 @@+## Version 1.4.1++- Enable X25519 in default parameters [#265](https://github.com/vincenthz/hs-tls/pull/265)+- Checking EOF in bye [#262] (https://github.com/vincenthz/hs-tls/pull/262)+- Improving validation in DH key exchange [#256](https://github.com/vincenthz/hs-tls/pull/256)+- Handle TCP reset during handshake [#251](https://github.com/vincenthz/hs-tls/pull/251)+- Accepting hlint suggestions.+ ## Version 1.4.0 - Wrap renegotiation failures with HandshakeFailed [#237](https://github.com/vincenthz/hs-tls/pull/237)
Network/TLS.hs view
@@ -15,6 +15,7 @@ , ServerParams(..) , DebugParams(..) , DHParams+ , DHPublic , ClientHooks(..) , ServerHooks(..) , Supported(..)@@ -23,6 +24,7 @@ , Handshake , Logging(..) , Measurement(..)+ , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) , defaultParamsClient@@ -137,7 +139,7 @@ , AlertDescription(..) , ClientRandom(..), ServerRandom(..) , Handshake)-import Network.TLS.Crypto (KxError(..), DHParams, Group(..))+import Network.TLS.Crypto (KxError(..), DHParams, DHPublic, Group(..)) import Network.TLS.Cipher import Network.TLS.Hooks import Network.TLS.Measurement
Network/TLS/Backend.hs view
@@ -21,12 +21,11 @@ , Backend(..) ) where -import Data.ByteString (ByteString)+import Network.TLS.Imports import qualified Data.ByteString as B import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush, hClose) #ifdef INCLUDE_NETWORK-import Control.Monad import qualified Network.Socket as Network (Socket, close) import qualified Network.Socket.ByteString as Network #endif@@ -73,7 +72,7 @@ instance HasBackend Network.Socket where initializeBackend _ = return () getBackend sock = Backend (return ()) (Network.close sock) (Network.sendAll sock) recvAll- where recvAll n = B.concat `fmap` loop n+ where recvAll n = B.concat <$> loop n where loop 0 = return [] loop left = do r <- safeRecv sock left@@ -87,7 +86,7 @@ initializeBackend _ = return () getBackend sock = Backend (return ()) (Hans.close sock) sendAll recvAll where sendAll x = do- amt <- fromIntegral `fmap` Hans.sendBytes sock (L.fromStrict x)+ amt <- fromIntegral <$> Hans.sendBytes sock (L.fromStrict x) if (amt == 0) || (amt == B.length x) then return () else sendAll (B.drop amt x)
Network/TLS/Cipher.hs view
@@ -53,7 +53,7 @@ show (BulkStateStream _) = "BulkStateStream" show (BulkStateBlock _) = "BulkStateBlock" show (BulkStateAEAD _) = "BulkStateAEAD"- show (BulkStateUninitialized) = "BulkStateUninitialized"+ show BulkStateUninitialized = "BulkStateUninitialized" newtype BulkStream = BulkStream (B.ByteString -> (B.ByteString, BulkStream))
Network/TLS/Compression.hs view
@@ -23,9 +23,8 @@ , compressionIntersectID ) where -import Data.Word import Network.TLS.Types (CompressionID)-import Data.ByteString (ByteString)+import Network.TLS.Imports import Control.Arrow (first) -- | supported compression algorithms need to be part of this class@@ -60,7 +59,7 @@ -- the function keeps the list of compression in order, to be able to find quickly the prefered -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression]-compressionIntersectID l ids = filter (\c -> elem (compressionID c) ids) l+compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l -- | This is the default compression which is a NOOP. data NullCompression = NullCompression
Network/TLS/Context.hs view
@@ -121,7 +121,7 @@ seed <- case debugSeed debug of Nothing -> do seed <- seedNew- debugPrintSeed debug $ seed+ debugPrintSeed debug seed return seed Just determ -> return determ let rng = newStateRNG seed@@ -145,7 +145,7 @@ lockRead <- newMVar () lockState <- newMVar () - return $ Context+ return Context { ctxConnection = getBackend backend , ctxShared = shared , ctxSupported = supported
Network/TLS/Context/Internal.hs view
@@ -65,7 +65,7 @@ import Network.TLS.Record.State import Network.TLS.Parameters import Network.TLS.Measurement-import Data.ByteString (ByteString)+import Network.TLS.Imports import qualified Data.ByteString as B import Control.Concurrent.MVar@@ -195,7 +195,7 @@ usingHState ctx f = liftIO $ modifyMVar (ctxHandshake ctx) $ \mst -> case mst of Nothing -> throwCore $ Error_Misc "missing handshake"- Just st -> return $ swap (Just `fmap` runHandshake st f)+ Just st -> return $ swap (Just <$> runHandshake st f) getHState :: Context -> IO (Maybe HandshakeState) getHState ctx = liftIO $ readMVar (ctxHandshake ctx)
Network/TLS/Core.hs view
@@ -39,7 +39,6 @@ import Network.TLS.Util (catchException) import qualified Network.TLS.State as S import qualified Data.ByteString as B-import Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E @@ -52,7 +51,9 @@ -- -- this doesn't actually close the handle bye :: MonadIO m => Context -> m ()-bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)]+bye ctx = do+ eof <- liftIO $ ctxEOF ctx+ unless eof $ sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] -- | If the ALPN extensions have been used, this will -- return get the protocol agreed upon.@@ -92,7 +93,7 @@ onError err = terminate err AlertLevel_Fatal InternalError (show err) - process (Handshake [ch@(ClientHello {})]) =+ process (Handshake [ch@ClientHello{}]) = handshakeWith ctx ch >> recvData ctx process (Handshake [hr@HelloRequest]) = handshakeWith ctx hr >> recvData ctx
Network/TLS/Credentials.hs view
@@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unknown --+{-# LANGUAGE CPP #-} module Network.TLS.Credentials ( Credential , Credentials(..)@@ -19,12 +20,9 @@ , credentialMatchesHashSignatures ) where -import Data.ByteString (ByteString)-import Data.Monoid-import Data.Maybe (catMaybes)-import Data.List (find) import Network.TLS.Crypto import Network.TLS.X509+import Network.TLS.Imports import Data.X509.File import Data.X509.Memory import Data.X509@@ -36,9 +34,16 @@ newtype Credentials = Credentials [Credential] +#if MIN_VERSION_base(4,9,0)+instance Semigroup Credentials where+ Credentials l1 <> Credentials l2 = Credentials (l1 ++ l2)+#endif+ instance Monoid Credentials where mempty = Credentials []+#if !(MIN_VERSION_base(4,11,0)) mappend (Credentials l1) (Credentials l2) = Credentials (l1 ++ l2)+#endif -- | try to create a new credential object from a public certificate -- and the associated private key that are stored on the filesystem@@ -86,7 +91,7 @@ (k:_) -> Right (CertificateChain . concat $ x509 : chains, k) credentialsListSigningAlgorithms :: Credentials -> [DigitalSignatureAlg]-credentialsListSigningAlgorithms (Credentials l) = catMaybes $ map credentialCanSign l+credentialsListSigningAlgorithms (Credentials l) = mapMaybe credentialCanSign l credentialsFindForSigning :: DigitalSignatureAlg -> Credentials -> Maybe Credential credentialsFindForSigning sigAlg (Credentials l) = find forSigning l
Network/TLS/Crypto.hs view
@@ -26,6 +26,7 @@ , PrivateKey , SignatureParams(..) , findDigitalSignatureAlg+ , findFiniteFieldGroup , kxEncrypt , kxDecrypt , kxSign@@ -37,8 +38,8 @@ import qualified Crypto.Hash as H import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert)-import Data.ByteString (ByteString) import Crypto.Random+import qualified Crypto.PubKey.DH as DH import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Prim as ECC@@ -52,11 +53,11 @@ import Network.TLS.Crypto.DH import Network.TLS.Crypto.IES import Network.TLS.Crypto.Types+import Network.TLS.Imports import Data.ASN1.Types import Data.ASN1.Encoding import Data.ASN1.BinaryEncoding (DER(..), BER(..))-import Data.List (find) {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey@@ -76,6 +77,15 @@ --(PubKeyECDSA _, PrivKeyECDSA _) -> Just ECDSA _ -> Nothing +findFiniteFieldGroup :: DH.Params -> Maybe Group+findFiniteFieldGroup params = lookup (pg params) table+ where+ pg (DH.Params p g _) = (p, g)++ table = [ (pg prms, grp) | grp <- availableFFGroups+ , let Just prms = dhParamsForGroup grp+ ]+ -- functions to use the hidden class. hashInit :: Hash -> HashContext hashInit MD5 = HashContext $ ContextSimple (H.hashInit :: H.Context H.MD5)@@ -160,11 +170,11 @@ generalizeRSAError (Right x) = Right x kxEncrypt :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)-kxEncrypt (PubKeyRSA pk) b = generalizeRSAError `fmap` RSA.encrypt pk b+kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)-kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError `fmap` RSA.decryptSafer pk b+kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) data RSAEncoding = RSApkcs1 | RSApss deriving (Show,Eq)@@ -198,10 +208,10 @@ Right asn1 -> case asn1 of Start Sequence:IntVal r:IntVal s:End Sequence:_ ->- Just $ DSA.Signature { DSA.sign_r = r, DSA.sign_s = s }+ Just DSA.Signature { DSA.sign_r = r, DSA.sign_s = s } _ -> Nothing-kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = maybe False id $ do+kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ do -- get the curve name and the public key data (curveName, pubBS) <- case key of PubKeyEC_Named curveName' pub -> Just (curveName',pub)@@ -264,9 +274,9 @@ -> ByteString -> r (Either KxError ByteString) kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApkcs1) msg =- generalizeRSAError `fmap` rsaSignHash hashAlg pk msg+ generalizeRSAError <$> rsaSignHash hashAlg pk msg kxSign (PrivKeyRSA pk) (RSAParams hashAlg RSApss) msg =- generalizeRSAError `fmap` rsapssSignHash hashAlg pk msg+ generalizeRSAError <$> rsapssSignHash hashAlg pk msg kxSign (PrivKeyDSA pk) DSSParams msg = do sign <- DSA.sign pk H.SHA1 msg return (Right $ encodeASN1' DER $ dsaSequence sign)
Network/TLS/Crypto/DH.hs view
@@ -4,6 +4,7 @@ DHParams , DHPublic , DHPrivate+ , DHKey -- * DH methods , dhPublic@@ -13,6 +14,7 @@ , dhParamsGetG , dhGenerateKeyPair , dhGetShared+ , dhValid , dhUnwrap , dhUnwrapPublic ) where@@ -39,7 +41,7 @@ dhGenerateKeyPair :: MonadRandom r => DHParams -> r (DHPrivate, DHPublic) dhGenerateKeyPair params = do priv <- DH.generatePrivate params- let pub = DH.generatePublic params priv+ let pub = DH.calculatePublic params priv return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey@@ -49,6 +51,12 @@ -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) premaster secret in SSL/TLS before version 1.3. stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)++-- Check that group element in not in the 2-element subgroup { 1, p - 1 }.+-- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.+-- This verification is enough when using a safe prime.+dhValid :: DHParams -> Integer -> Bool+dhValid (DH.Params p _ _) y = 1 < y && y < p - 1 dhUnwrap :: DHParams -> DHPublic -> [Integer] dhUnwrap (DH.Params p g _) (DH.PublicNumber y) = [p,g,y]
Network/TLS/Crypto/IES.hs view
@@ -16,13 +16,19 @@ , groupGetShared , encodeGroupPublic , decodeGroupPublic+ -- * Compatibility with 'Network.TLS.Crypto.DH'+ , dhParamsForGroup+ , dhGroupGenerateKeyPair+ , dhGroupGetPubShared ) where import Control.Arrow import Crypto.ECC import Crypto.Error-import Crypto.PubKey.DH+import Crypto.Number.Generate+import Crypto.PubKey.DH hiding (generateParams) import Crypto.PubKey.ECIES+import qualified Data.ByteArray as B import Data.Proxy import Network.TLS.Crypto.Types import Network.TLS.Extra.FFDHE@@ -71,6 +77,14 @@ x448 :: Proxy Curve_X448 x448 = Proxy +dhParamsForGroup :: Group -> Maybe Params+dhParamsForGroup FFDHE2048 = Just ffdhe2048+dhParamsForGroup FFDHE3072 = Just ffdhe3072+dhParamsForGroup FFDHE4096 = Just ffdhe4096+dhParamsForGroup FFDHE6144 = Just ffdhe6144+dhParamsForGroup FFDHE8192 = Just ffdhe8192+dhParamsForGroup _ = Nothing+ groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic) groupGenerateKeyPair P256 = (GroupPri_P256,GroupPub_P256) `fs` curveGenerateKeyPair p256@@ -82,12 +96,23 @@ (GroupPri_X255,GroupPub_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 = (GroupPri_X448,GroupPub_X448) `fs` curveGenerateKeyPair x448-groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048-groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072-groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096-groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144-groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192+groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048+groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072+groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096+groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144+groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192 +dhGroupGenerateKeyPair :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber)+dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048)+dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072)+dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096)+dhGroupGenerateKeyPair FFDHE6144 = addParams ffdhe6144 (gen' ffdhe6144 exp6144)+dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192)+dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp)++addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b)+addParams params = fmap $ \(a, b) -> (params, a, b)+ fs :: MonadRandom r => (Scalar a -> GroupPrivate, Point a -> GroupPublic) -> r (KeyPair a)@@ -100,14 +125,18 @@ gen :: MonadRandom r => Params+ -> Int -> (PrivateNumber -> GroupPrivate) -> (PublicNumber -> GroupPublic) -> r (GroupPrivate, GroupPublic)-gen params priTag pubTag = do- pri <- generatePrivate params- let pub = calculatePublic params pri- return (priTag pri, pubTag pub)+gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits +gen' :: MonadRandom r+ => Params+ -> Int+ -> r (PrivateNumber, PublicNumber)+gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+ groupGetPubShared :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey)) groupGetPubShared (GroupPub_P256 pub) = fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub@@ -119,38 +148,62 @@ fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub groupGetPubShared (GroupPub_X448 pub) = fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 pub GroupPub_FFDHE8192+groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048+groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072+groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096+groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144+groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192 +dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))+dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub+dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub+dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub+dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub+dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub+dhGroupGetPubShared _ _ = return Nothing+ getPubShared :: MonadRandom r => Params+ -> Int -> PublicNumber -> (PublicNumber -> GroupPublic) -> r (Maybe (GroupPublic, GroupKey))-getPubShared params pub pubTag = do- mypri <- generatePrivate params+getPubShared params expBits pub pubTag | not (valid params pub) = return Nothing+ | otherwise = do+ mypri <- generatePriv expBits let mypub = calculatePublic params mypri let SharedKey share = getShared params mypri pub return $ Just (pubTag mypub, SharedSecret share) +getPubShared' :: MonadRandom r+ => Params+ -> Int+ -> PublicNumber+ -> r (Maybe (PublicNumber, SharedKey))+getPubShared' params expBits pub+ | not (valid params pub) = return Nothing+ | otherwise = do+ mypri <- generatePriv expBits+ let share = stripLeadingZeros (getShared params mypri pub)+ return $ Just (calculatePublic params mypri, SharedKey share)+ groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri-groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = Just $ calcShared ffdhe2048 pub pri-groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = Just $ calcShared ffdhe3072 pub pri-groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = Just $ calcShared ffdhe4096 pub pri-groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = Just $ calcShared ffdhe6144 pub pri-groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = Just $ calcShared ffdhe8192 pub pri+groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri+groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri+groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri+groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri+groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri groupGetShared _ _ = Nothing -calcShared :: Params -> PublicNumber -> PrivateNumber -> SharedSecret-calcShared params pub pri = SharedSecret share+calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret+calcShared params pub pri+ | valid params pub = Just $ SharedSecret share+ | otherwise = Nothing where SharedKey share = getShared params pri pub @@ -180,3 +233,31 @@ decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs++-- Check that group element in not in the 2-element subgroup { 1, p - 1 }.+-- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.+valid :: Params -> PublicNumber -> Bool+valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1++-- strips leading zeros from the result of getShared, as required+-- for DH(E) premaster secret in SSL/TLS before version 1.3.+stripLeadingZeros :: SharedKey -> B.ScrubbedBytes+stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb++-- Use short exponents as optimization, see RFC 7919 section 5.2.+generatePriv :: MonadRandom r => Int -> r PrivateNumber+generatePriv e = PrivateNumber <$> generateParams e (Just SetHighest) False++-- Short exponent bit sizes from RFC 7919 appendix A, rounded to next+-- multiple of 16 bits, i.e. going through a function like:+-- let shortExp n = head [ e | i <- [1..], let e = n + i, e `mod` 16 == 0 ]+exp2048 :: Int+exp3072 :: Int+exp4096 :: Int+exp6144 :: Int+exp8192 :: Int+exp2048 = 240 -- shortExp 225+exp3072 = 288 -- shortExp 275+exp4096 = 336 -- shortExp 325+exp6144 = 384 -- shortExp 375+exp8192 = 416 -- shortExp 400
Network/TLS/Crypto/Types.hs view
@@ -11,8 +11,14 @@ | FFDHE2048 | FFDHE3072 | FFDHE4096 | FFDHE6144 | FFDHE8192 deriving (Eq, Show) +availableFFGroups :: [Group]+availableFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192]++availableECGroups :: [Group]+availableECGroups = [P256,P384,P521,X25519,X448]+ availableGroups :: [Group]-availableGroups = [P256,P384,P521,X25519,X448]+availableGroups = availableECGroups ++ availableFFGroups -- Digital signature algorithm, in close relation to public/private key types -- and cipher key exchange.
Network/TLS/Extension.hs view
@@ -37,11 +37,6 @@ , SignatureAlgorithms(..) ) where -import Control.Monad--import Data.Word-import Data.Maybe (fromMaybe, catMaybes)-import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -157,8 +152,7 @@ -- | Server Name extension including the name type and the associated name. -- the associated name decoding is dependant of its name type. -- name type = 0 : hostname-data ServerName = ServerName [ServerNameType]- deriving (Show,Eq)+newtype ServerName = ServerName [ServerNameType] deriving (Show,Eq) data ServerNameType = ServerNameHostName HostName | ServerNameOther (Word8, ByteString)@@ -169,7 +163,7 @@ extensionEncode (ServerName l) = runPut $ putOpaque16 (runPut $ mapM_ encodeNameType l) where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt,opaque)) = putWord8 nt >> putBytes opaque- extensionDecode _ = runGetMaybe (getWord16 >>= \len -> getList (fromIntegral len) getServerName >>= return . ServerName)+ extensionDecode _ = runGetMaybe (getWord16 >>= \len -> ServerName <$> getList (fromIntegral len) getServerName) where getServerName = do ty <- getWord8 sname <- getOpaque16@@ -178,8 +172,7 @@ _ -> ServerNameOther (ty, sname)) -- | Max fragment extension with length from 512 bytes to 4096 bytes-data MaxFragmentLength = MaxFragmentLength MaxFragmentEnum- deriving (Show,Eq)+newtype MaxFragmentLength = MaxFragmentLength MaxFragmentEnum deriving (Show,Eq) data MaxFragmentEnum = MaxFragment512 | MaxFragment1024 | MaxFragment2048 | MaxFragment4096 deriving (Show,Eq) @@ -213,8 +206,7 @@ else return $ SecureRenegotiation opaque Nothing -- | Application Layer Protocol Negotiation (ALPN)-data ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString]- deriving (Show,Eq)+newtype ApplicationLayerProtocolNegotiation = ApplicationLayerProtocolNegotiation [ByteString] deriving (Show,Eq) instance Extension ApplicationLayerProtocolNegotiation where extensionID _ = extensionID_ApplicationLayerProtocolNegotiation@@ -231,17 +223,15 @@ _ -> (:) <$> getOpaque8 <*> getALPN' -data NegotiatedGroups = NegotiatedGroups [Group]- deriving (Show,Eq)+newtype NegotiatedGroups = NegotiatedGroups [Group] deriving (Show,Eq) -- on decode, filter all unknown curves instance Extension NegotiatedGroups where extensionID _ = extensionID_NegotiatedGroups extensionEncode (NegotiatedGroups groups) = runPut $ putWords16 $ map fromEnumSafe16 groups- extensionDecode _ = runGetMaybe (NegotiatedGroups . catMaybes . map toEnumSafe16 <$> getWords16)+ extensionDecode _ = runGetMaybe (NegotiatedGroups . mapMaybe toEnumSafe16 <$> getWords16) -data EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat]- deriving (Show,Eq)+newtype EcPointFormatsSupported = EcPointFormatsSupported [EcPointFormat] deriving (Show,Eq) data EcPointFormat = EcPointFormat_Uncompressed@@ -263,18 +253,17 @@ instance Extension EcPointFormatsSupported where extensionID _ = extensionID_EcPointFormats extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEnumSafe8 formats- extensionDecode _ = runGetMaybe (EcPointFormatsSupported . catMaybes . map toEnumSafe8 <$> getWords8)+ extensionDecode _ = runGetMaybe (EcPointFormatsSupported . mapMaybe toEnumSafe8 <$> getWords8) data SessionTicket = SessionTicket deriving (Show,Eq) instance Extension SessionTicket where extensionID _ = extensionID_SessionTicket- extensionEncode (SessionTicket {}) = runPut $ return ()+ extensionEncode SessionTicket{} = runPut $ return () extensionDecode _ = runGetMaybe (return SessionTicket) -data HeartBeat = HeartBeat HeartBeatMode- deriving (Show,Eq)+newtype HeartBeat = HeartBeat HeartBeatMode deriving (Show,Eq) data HeartBeatMode = HeartBeat_PeerAllowedToSend@@ -297,8 +286,7 @@ Just (Just mode) -> Just $ HeartBeat mode _ -> Nothing -data SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm]- deriving (Show,Eq)+newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] deriving (Show,Eq) instance Extension SignatureAlgorithms where extensionID _ = extensionID_SignatureAlgorithms
Network/TLS/Extra/Cipher.hs view
@@ -56,6 +56,7 @@ import Network.TLS.Types (Version(..)) import Network.TLS.Cipher+import Network.TLS.Imports import Data.Tuple (swap) import Crypto.Cipher.AES@@ -123,7 +124,7 @@ noFail = throwCryptoError makeIV_ :: BlockCipher a => B.ByteString -> IV a-makeIV_ = maybe (error "makeIV_") id . makeIV+makeIV_ = fromMaybe (error "makeIV_") . makeIV tripledes_ede :: BulkDirection -> BulkKey -> BulkBlock tripledes_ede BulkEncrypt key =@@ -134,7 +135,7 @@ in (\iv input -> let output = cbcDecrypt ctx (tripledes_iv iv) input in (output, takelast 8 input)) tripledes_iv :: BulkIV -> IV DES_EDE3-tripledes_iv iv = maybe (error "tripledes cipher iv internal error") id $ makeIV iv+tripledes_iv iv = fromMaybe (error "tripledes cipher iv internal error") $ makeIV iv rc4 :: BulkDirection -> BulkKey -> BulkStream rc4 _ bulkKey = BulkStream (combineRC4 $ RC4.initialize bulkKey)
Network/TLS/Handshake.hs view
@@ -18,29 +18,33 @@ import Network.TLS.Struct import Network.TLS.IO import Network.TLS.Util (catchException)+import Network.TLS.Imports import Network.TLS.Handshake.Common import Network.TLS.Handshake.Client import Network.TLS.Handshake.Server import Control.Monad.State.Strict-import Control.Exception (fromException)+import Control.Exception (IOException, catch, fromException) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegotiation handshake :: MonadIO m => Context -> m () handshake ctx =- liftIO $ handleException ctx $ withRWLock ctx (ctxDoHandshake ctx $ ctx)+ liftIO $ handleException ctx $ withRWLock ctx (ctxDoHandshake ctx ctx) -- Handshake when requested by the remote end -- This is called automatically by 'recvData' handshakeWith :: MonadIO m => Context -> Handshake -> m () handshakeWith ctx hs =- liftIO $ handleException ctx $ withRWLock ctx ((ctxDoHandshakeWith ctx) ctx hs)+ liftIO $ handleException ctx $ withRWLock ctx $ ctxDoHandshakeWith ctx ctx hs handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do- let tlserror = maybe (Error_Misc $ show exception) id $ fromException exception+ let tlserror = fromMaybe (Error_Misc $ show exception) $ fromException exception setEstablished ctx False- sendPacket ctx (errorToAlert tlserror)+ sendPacket ctx (errorToAlert tlserror) `catch` ignoreIOErr handshakeFailed tlserror+ where+ ignoreIOErr :: IOException -> IO ()+ ignoreIOErr _ = return ()
Network/TLS/Handshake/Client.hs view
@@ -28,10 +28,7 @@ import Network.TLS.Util (bytesEq, catchException) import Network.TLS.Types import Network.TLS.X509-import Data.Maybe-import Data.List (find, intersect) import qualified Data.ByteString as B-import Data.ByteString.Char8 () import Control.Monad.State.Strict import Control.Exception (SomeException)@@ -66,7 +63,7 @@ getExtensions = sequence [sniExtension ,secureReneg ,alpnExtension- ,curveExtension+ ,groupExtension ,ecPointExtension --,sessionTicketExtension ,signatureAlgExtension@@ -93,7 +90,7 @@ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - curveExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups ((supportedGroups $ ctxSupported ctx) `intersect` availableGroups)+ groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend@@ -102,8 +99,8 @@ 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+ crand <- ClientRandom <$> getStateRNG ctx 32+ let clientSession = Session . (fst <$>) $ clientWantSessionResume cparams highestVer = maximum $ supportedVersions $ ctxSupported ctx extensions <- catMaybes <$> getExtensions startHandshake ctx highestVer crand@@ -193,11 +190,30 @@ where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams- (clientDHPriv, clientDHPub) <- generateDHE ctx (serverDHParamsToParams serverParams) - let premaster = dhGetShared (serverDHParamsToParams serverParams)- clientDHPriv- (serverDHParamsToPublic serverParams)+ let params = serverDHParamsToParams serverParams+ ffGroup = findFiniteFieldGroup params+ srvpub = serverDHParamsToPublic serverParams++ (clientDHPub, premaster) <-+ case ffGroup of+ Nothing -> do+ groupUsage <- (onCustomFFDHEGroup $ clientHooks cparams) params srvpub `catchException`+ throwMiscErrorOnException "custom group callback failed"+ case groupUsage of+ GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity)+ GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)+ GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)+ GroupUsageValid -> do+ (clientDHPriv, clientDHPub) <- generateDHE ctx params+ let premaster = dhGetShared params clientDHPriv srvpub+ return (clientDHPub, premaster)+ Just grp -> do+ dhePair <- generateFFDHEShared ctx grp srvpub+ case dhePair of+ Nothing -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)+ Just pair -> return pair+ usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster return $ CKX_DH clientDHPub@@ -227,33 +243,30 @@ -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. --- certSent <- usingHState ctx $ getClientCertSent- case certSent of- True -> do- sigAlg <- getLocalSignatureAlg-- mhashSig <- case usedVersion of- TLS12 -> do- Just (_, Just hashSigs, _) <- usingHState ctx $ getClientCertRequest- -- The values in the "signature_algorithms" extension- -- are in descending order of preference.- -- However here the algorithms are selected according- -- to client preference in 'supportedHashSignatures'.- let suppHashSigs = supportedHashSignatures $ ctxSupported ctx- matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs- hashSigs' = filter (\ a -> a `elem` hashSigs) matchHashSigs+ certSent <- usingHState ctx getClientCertSent+ when certSent $ do+ sigAlg <- getLocalSignatureAlg - when (null hashSigs') $- throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure)- return $ Just $ head hashSigs'- _ -> return Nothing+ mhashSig <- case usedVersion of+ TLS12 -> do+ Just (_, Just hashSigs, _) <- usingHState ctx getClientCertRequest+ -- The values in the "signature_algorithms" extension+ -- are in descending order of preference.+ -- However here the algorithms are selected according+ -- to client preference in 'supportedHashSignatures'.+ let suppHashSigs = supportedHashSignatures $ ctxSupported ctx+ matchHashSigs = filter (sigAlg `signatureCompatible`) suppHashSigs+ hashSigs' = filter (`elem` hashSigs) matchHashSigs - -- Fetch all handshake messages up to now.- msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages- sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs- sendPacket ctx $ Handshake [CertVerify sigDig]+ when (null hashSigs') $+ throwCore $ Error_Protocol ("no " ++ show sigAlg ++ " hash algorithm in common with the server", True, HandshakeFailure)+ return $ Just $ head hashSigs'+ _ -> return Nothing - _ -> return ()+ -- Fetch all handshake messages up to now.+ msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages+ sigDig <- createCertificateVerify ctx usedVersion sigAlg mhashSig msgs+ sendPacket ctx $ Handshake [CertVerify sigDig] getLocalSignatureAlg = do pk <- usingHState ctx getLocalPrivateKey@@ -285,7 +298,7 @@ onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)- case find ((==) rver) (supportedVersions $ ctxSupported ctx) of+ case find (== rver) (supportedVersions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server version " ++ show rver ++ " is not supported", True, ProtocolVersion) Just _ -> return () -- find the compression and cipher methods that the server want to use.@@ -298,7 +311,7 @@ -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail.- when (not $ null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) exts) $+ unless (null $ filter (not . flip elem sentExts . (\(ExtensionRaw i _) -> i)) exts) $ throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) let resumingSession =@@ -311,11 +324,11 @@ setVersion rver usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg - case extensionDecode False `fmap` (extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts) of+ case extensionDecode False <$> extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts of Just (Just (ApplicationLayerProtocolNegotiation [proto])) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of- Just protos -> when (elem proto protos) $ do+ Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return ()@@ -331,7 +344,7 @@ processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do -- run certificate recv hook- ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks $ certs)+ ctxWithHooks ctx (\hooks -> hookRecvCertificates hooks certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of@@ -376,15 +389,15 @@ -- we need to resolve the result. and recall processWithCipher .. (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature signatureType = do- -- TODO verify DHParams+ -- FIXME verify if FF group is one of supported groups verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature- when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure)+ unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams, True, HandshakeFailure) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature signatureType = do- -- TODO verify DHParams+ -- FIXME verify if EC group is one of supported groups verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature- when (not verified) $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure)+ unless verified $ throwCore $ Error_Protocol ("bad " ++ show signatureType ++ " signature for ecdhparams", True, HandshakeFailure) usingHState ctx $ setServerECDHParams ecdhparams processServerKeyExchange ctx p = processCertificateRequest ctx p
Network/TLS/Handshake/Common.hs view
@@ -32,8 +32,7 @@ import Network.TLS.Types import Network.TLS.Cipher import Network.TLS.Util-import Data.List (find)-import Data.ByteString.Char8 (ByteString)+import Network.TLS.Imports import Control.Monad.State.Strict import Control.Exception (throwIO)@@ -45,12 +44,12 @@ errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)] -unexpected :: String -> Maybe [Char] -> IO a+unexpected :: String -> Maybe String -> IO a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) newSession :: Context -> IO Session newSession ctx- | supportedSession $ ctxSupported ctx = getStateRNG ctx 32 >>= return . Session . Just+ | supportedSession $ ctxSupported ctx = Session . Just <$> getStateRNG ctx 32 | otherwise = return $ Session Nothing -- | when a new handshake is done, wrap up & clean up.@@ -117,7 +116,7 @@ onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing runRecvState :: Context -> RecvState IO -> IO ()-runRecvState _ (RecvStateDone) = return ()+runRecvState _ RecvStateDone = return () runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx @@ -129,7 +128,7 @@ tx <- liftIO $ readMVar (ctxTxState ctx) case mms of Nothing -> return Nothing- Just ms -> return $ Just $ SessionData+ Just ms -> return $ Just SessionData { sessionVersion = ver , sessionCipher = cipherID $ fromJust "cipher" $ stCipher tx , sessionCompression = compressionID $ stCompression tx
Network/TLS/Handshake/Key.hs view
@@ -15,9 +15,10 @@ , generateDHE , generateECDHE , generateECDHEShared+ , generateFFDHE+ , generateFFDHEShared ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Handshake.State@@ -25,6 +26,7 @@ import Network.TLS.Crypto import Network.TLS.Types import Network.TLS.Context.Internal+import Network.TLS.Imports {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem.@@ -68,3 +70,9 @@ generateECDHEShared :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey)) generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub++generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic)+generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp++generateFFDHEShared :: Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))+generateFFDHEShared ctx grp pub = usingState_ ctx $ withRNG $ dhGroupGetPubShared grp pub
Network/TLS/Handshake/Process.hs view
@@ -15,7 +15,6 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict (gets)-import Control.Monad import Control.Monad.IO.Class (liftIO) import Network.TLS.Types (Role(..), invertRole)@@ -94,8 +93,12 @@ role <- usingState_ ctx isClientContext serverParams <- usingHState ctx getServerDHParams+ let params = serverDHParamsToParams serverParams+ unless (dhValid params $ dhUnwrapPublic clientDHValue) $+ throwCore $ Error_Protocol ("invalid client public key", True, HandshakeFailure)+ dhpriv <- usingHState ctx getDHPrivate- let premaster = dhGetShared (serverDHParamsToParams serverParams) dhpriv clientDHValue+ let premaster = dhGetShared params dhpriv clientDHValue usingHState ctx $ setMasterSecretFromPre rver role premaster processClientKeyXchg ctx (CKX_ECDH bytes) = do
Network/TLS/Handshake/Server.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} -- | -- Module : Network.TLS.Handshake.Server -- License : BSD-style@@ -30,17 +29,7 @@ import Network.TLS.Handshake.Process import Network.TLS.Handshake.Key import Network.TLS.Measurement-import Data.Maybe (isJust, listToMaybe, mapMaybe)-import Data.List (findIndex, intersect) import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import Data.Ord (Down(..))-#if MIN_VERSION_base(4,8,0)-import Data.List (sortOn)-#else-import Data.List (sortBy)-import Data.Ord (comparing)-#endif import Control.Monad.State.Strict @@ -145,16 +134,24 @@ -- negotiated signature parameters. Then ciphers are evalutated from -- the resulting credentials. - let possibleGroups = negotiatedGroupsInCommon ctx exts- hasCommonGroupForECDHE = not (null possibleGroups)+ let possibleGroups = negotiatedGroupsInCommon ctx exts+ possibleECGroups = possibleGroups `intersect` availableECGroups+ possibleFFGroups = possibleGroups `intersect` availableFFGroups+ hasCommonGroupForECDHE = not (null possibleECGroups)+ hasCommonGroupForFFDHE = not (null possibleFFGroups)+ hasCustomGroupForFFDHE = isJust (serverDHEParams sparams)+ canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE hasCommonGroup cipher = case cipherKeyExchange cipher of+ CipherKeyExchange_DH_Anon -> canFFDHE+ CipherKeyExchange_DHE_RSA -> canFFDHE+ CipherKeyExchange_DHE_DSS -> canFFDHE CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE _ -> True -- group not used - -- Ciphers are selected according to TLS version, availability of ECDHE- -- group and credential depending on key exchange.+ -- Ciphers are selected according to TLS version, availability of+ -- (EC)DHE group and credential depending on key exchange. cipherAllowed cipher = cipherAllowedForVersion chosenVersion cipher && hasCommonGroup cipher selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials) @@ -206,7 +203,7 @@ cred <- case cipherKeyExchange usedCipher of CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds- CipherKeyExchange_DH_Anon -> return $ Nothing+ CipherKeyExchange_DH_Anon -> return Nothing CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds CipherKeyExchange_DHE_DSS -> return $ credentialsFindForSigning DSS signatureCreds CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning RSA signatureCreds@@ -372,8 +369,17 @@ extractCAname cert = certSubjectDN $ getCertificate cert setup_DHE = do- let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams- (priv, pub) <- generateDHE ctx dhparams+ let possibleFFGroups = negotiatedGroupsInCommon ctx exts `intersect` availableFFGroups+ (dhparams, priv, pub) <-+ case possibleFFGroups of+ [] ->+ let dhparams = fromJust "server DHE Params" $ serverDHEParams sparams+ in case findFiniteFieldGroup dhparams of+ Just g -> generateFFDHE ctx g+ Nothing -> do+ (priv, pub) <- generateDHE ctx dhparams+ return (dhparams, priv, pub)+ g:_ -> generateFFDHE ctx g let serverParams = serverDHParamsFrom dhparams pub @@ -416,8 +422,8 @@ return serverParams generateSKX_ECDHE sigAlg = do- let possibleGroups = negotiatedGroupsInCommon ctx exts- grp <- case possibleGroups of+ let possibleECGroups = negotiatedGroupsInCommon ctx exts `intersect` availableECGroups+ grp <- case possibleECGroups of [] -> throwCore $ Error_Protocol ("no common group", True, HandshakeFailure) g:_ -> return g serverParams <- setup_ECDHE grp@@ -485,31 +491,28 @@ verif <- checkCertificateVerify ctx usedVersion sigAlgExpected msgs dsig - case verif of- True -> do- -- When verification succeeds, commit the- -- client certificate chain to the context.- --- Just certs <- usingHState ctx getClientCertChain- usingState_ ctx $ setClientCertificateChain certs- return ()-- False -> do- -- Either verification failed because of an- -- invalid format (with an error message), or- -- the signature is wrong. In either case,- -- ask the application if it wants to- -- proceed, we will do that.- res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)- if res- then do- -- When verification fails, but the- -- application callbacks accepts, we- -- also commit the client certificate- -- chain to the context.- Just certs <- usingHState ctx getClientCertChain- usingState_ ctx $ setClientCertificateChain certs- else throwCore $ Error_Protocol ("verification failed", True, BadCertificate)+ if verif then do+ -- When verification succeeds, commit the+ -- client certificate chain to the context.+ --+ Just certs <- usingHState ctx getClientCertChain+ usingState_ ctx $ setClientCertificateChain certs+ return ()+ else do+ -- Either verification failed because of an+ -- invalid format (with an error message), or+ -- the signature is wrong. In either case,+ -- ask the application if it wants to+ -- proceed, we will do that.+ res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)+ if res then do+ -- When verification fails, but the+ -- application callbacks accepts, we+ -- also commit the client certificate+ -- chain to the context.+ Just certs <- usingHState ctx getClientCertChain+ usingState_ ctx $ setClientCertificateChain certs+ else throwCore $ Error_Protocol ("verification failed", True, BadCertificate) return $ RecvStateNext expectChangeCipher processCertificateVerify p = do@@ -529,7 +532,7 @@ _ -> throwCore $ Error_Protocol ("unsupported remote public key type", True, HandshakeFailure) expectChangeCipher ChangeCipherSpec = do- return $ RecvStateHandshake $ expectFinish+ return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") @@ -562,7 +565,7 @@ negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon ctx exts = case extensionLookup extensionID_NegotiatedGroups exts >>= extensionDecode False of Just (NegotiatedGroups clientGroups) ->- let serverGroups = supportedGroups (ctxSupported ctx) `intersect` availableGroups+ let serverGroups = supportedGroups (ctxSupported ctx) in serverGroups `intersect` clientGroups _ -> [] @@ -602,9 +605,9 @@ [] -> Nothing v:_ -> Just v --- We filter our allowed ciphers here according to server DHE parameters and--- dynamic credential lists. Credentials 'creds' come from server parameters--- but also SNI callback. When the key exchange requires a signature, we use a+-- We filter our allowed ciphers here according to dynamic credential lists.+-- Credentials 'creds' come from server parameters but also SNI callback.+-- When the key exchange requires a signature, we use a -- subset of this list named 'sigCreds'. This list has been filtered in order -- to remove certificates that are not compatible with hash/signature -- restrictions (TLS 1.2).@@ -613,9 +616,9 @@ where authorizedCKE cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> canEncryptRSA- CipherKeyExchange_DH_Anon -> canDHE- CipherKeyExchange_DHE_RSA -> canSignRSA && canDHE- CipherKeyExchange_DHE_DSS -> canSignDSS && canDHE+ CipherKeyExchange_DH_Anon -> True+ CipherKeyExchange_DHE_RSA -> canSignRSA+ CipherKeyExchange_DHE_DSS -> canSignDSS CipherKeyExchange_ECDHE_RSA -> canSignRSA -- unimplemented: EC CipherKeyExchange_ECDHE_ECDSA -> False@@ -628,14 +631,7 @@ CipherKeyExchange_ECDH_ECDSA -> False CipherKeyExchange_ECDH_RSA -> False - canDHE = isJust $ serverDHEParams sparams canSignDSS = DSS `elem` signingAlgs canSignRSA = RSA `elem` signingAlgs canEncryptRSA = isJust $ credentialsFindForDecrypting creds signingAlgs = credentialsListSigningAlgorithms sigCreds--#if !MIN_VERSION_base(4,8,0)-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =- map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))-#endif
Network/TLS/Handshake/Signature.hs view
@@ -129,7 +129,7 @@ -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do- cc <- usingState_ ctx $ isClientContext+ cc <- usingState_ ctx isClientContext DigitallySigned malg <$> signPrivate ctx cc sigParam toSign signatureVerify :: Context -> DigitallySigned -> DigitalSignatureAlg -> ByteString -> IO Bool@@ -149,7 +149,7 @@ -> CertVerifyData -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned _ bs) (sigParam, toVerify) = do- cc <- usingState_ ctx $ isClientContext+ cc <- usingState_ ctx isClientContext verifyPublic ctx cc sigParam toVerify bs digitallySignParams :: Context -> ByteString -> DigitalSignatureAlg -> Maybe HashAndSignatureAlgorithm -> IO DigitallySigned
Network/TLS/Handshake/State.hs view
@@ -57,11 +57,10 @@ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Types-import Control.Applicative (Applicative, (<$>))+import Network.TLS.Imports import Control.Monad.State.Strict import Data.X509 (CertificateChain) import Data.ByteArray (ByteArrayAccess)-import Data.ByteString (ByteString) data HandshakeKeyState = HandshakeKeyState { hksRemotePublicKey :: !(Maybe PubKey)@@ -69,7 +68,7 @@ } deriving (Show) data HandshakeState = HandshakeState- { hstClientVersion :: !(Version)+ { hstClientVersion :: !Version , hstClientRandom :: !ClientRandom , hstServerRandom :: !(Maybe ServerRandom) , hstMasterSecret :: !(Maybe ByteString)@@ -99,7 +98,7 @@ instance MonadState HandshakeState HandshakeM where put x = HandshakeM (put x)- get = HandshakeM (get)+ get = HandshakeM get #if MIN_VERSION_mtl(2,1,0) state f = HandshakeM (state f) #endif
Network/TLS/Hooks.hs view
@@ -28,10 +28,10 @@ defaultLogging :: Logging defaultLogging = Logging- { loggingPacketSent = (\_ -> return ())- , loggingPacketRecv = (\_ -> return ())- , loggingIOSent = (\_ -> return ())- , loggingIORecv = (\_ _ -> return ())+ { loggingPacketSent = \_ -> return ()+ , loggingPacketRecv = \_ -> return ()+ , loggingIOSent = \_ -> return ()+ , loggingIORecv = \_ _ -> return () } instance Default Logging where@@ -49,7 +49,7 @@ defaultHooks :: Hooks defaultHooks = Hooks- { hookRecvHandshake = \hs -> return hs+ { hookRecvHandshake = return , hookRecvCertificates = return . const () , hookLogging = def }
Network/TLS/IO.hs view
@@ -19,8 +19,8 @@ import Network.TLS.Hooks import Network.TLS.Sending import Network.TLS.Receiving+import Network.TLS.Imports import qualified Data.ByteString as B-import Data.ByteString.Char8 (ByteString) import Data.IORef import Control.Monad.State.Strict@@ -44,7 +44,7 @@ return . Left $ if B.null hdrbs then Error_EOF- else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))+ else Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ show (B.length hdrbs)) -- | recvRecord receive a full TLS record (header + data), from the other side.@@ -103,7 +103,7 @@ pkt <- case pktRecv of Right (Handshake hss) -> ctxWithHooks ctx $ \hooks ->- (mapM (hookRecvHandshake hooks) hss) >>= return . Right . Handshake+ Right . Handshake <$> mapM (hookRecvHandshake hooks) hss _ -> return pktRecv case pkt of Right p -> withLog ctx $ \logging -> loggingPacketRecv logging $ show p
Network/TLS/Imports.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} -- Char8+ -- | -- Module : Network.TLS.Imports -- License : BSD-style@@ -5,24 +9,57 @@ -- Stability : experimental -- Portability : unknown ---{-# LANGUAGE NoImplicitPrelude #-} module Network.TLS.Imports ( -- generic exports ByteString- , Control.Applicative.Applicative(..)- , (Control.Applicative.<$>)- , Data.Monoid.Monoid(..)+ , module Data.ByteString.Char8 -- instance+ , module Control.Applicative+ , module Control.Monad+ , module Data.Bits+ , module Data.List+ , module Data.Maybe+#if MIN_VERSION_base(4,9,0)+ , module Data.Semigroup+#else+ , module Data.Monoid+#endif+ , module Data.Ord+ , module Data.Word+#if !MIN_VERSION_base(4,8,0)+ , sortOn+#endif -- project definition , showBytesHex ) where -import qualified Control.Applicative-import qualified Data.Monoid+import Data.ByteString (ByteString)+import Data.ByteString.Char8 () -import Data.ByteString (ByteString)-import Data.ByteArray.Encoding as B-import qualified Prelude+import Control.Applicative+import Control.Monad+import Data.Bits+import Data.List+import Data.Maybe hiding (fromJust)+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup+#else+import Data.Monoid+#endif+import Data.Ord+import Data.Word -showBytesHex :: ByteString -> Prelude.String-showBytesHex bs = Prelude.show (B.convertToBase B.Base16 bs :: ByteString)+import Data.ByteArray.Encoding as B+import qualified Prelude as P++#if !MIN_VERSION_base(4,8,0)+import Prelude ((.))++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f =+ map P.snd . sortBy (comparing P.fst) . map (\x -> let y = f x in y `P.seq` (y, x))+#endif++showBytesHex :: ByteString -> P.String+showBytesHex bs = P.show (B.convertToBase B.Base16 bs :: ByteString)+
Network/TLS/MAC.hs view
@@ -17,9 +17,8 @@ import Network.TLS.Crypto import Network.TLS.Types-import Data.ByteString (ByteString)+import Network.TLS.Imports import qualified Data.ByteString as B-import Data.Bits (xor) type HMAC = ByteString -> ByteString -> ByteString
Network/TLS/Measurement.hs view
@@ -14,7 +14,7 @@ , incrementNbHandshakes ) where -import Data.Word+import Network.TLS.Imports -- | record some data about this connection. data Measurement = Measurement
Network/TLS/Packet.hs view
@@ -63,9 +63,6 @@ import Network.TLS.Struct import Network.TLS.Wire import Network.TLS.Cap-import Data.Maybe (fromJust)-import Data.Word-import Control.Monad import Data.ASN1.Types (fromASN1, toASN1) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..))@@ -73,7 +70,6 @@ import Network.TLS.Crypto import Network.TLS.MAC import Network.TLS.Cipher (CipherKeyExchangeType(..), Cipher(..))-import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.ByteArray (ByteArrayAccess)@@ -151,7 +147,7 @@ (_, Nothing) -> fail "cannot decode alert description" decodeAlerts :: ByteString -> Either TLSError [(AlertLevel, AlertDescription)]-decodeAlerts = runGetErr "alerts" $ loop+decodeAlerts = runGetErr "alerts" loop where loop = do r <- remaining if r == 0@@ -216,7 +212,7 @@ compressions <- getWords8 r <- remaining exts <- if hasHelloExtensions ver && r > 0- then fmap fromIntegral getWord16 >>= getExtensions+ then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ClientHello ver random session ciphers compressions exts Nothing @@ -229,7 +225,7 @@ compressionid <- getWord8 r <- remaining exts <- if hasHelloExtensions ver && r > 0- then fmap fromIntegral getWord16 >>= getExtensions+ then fromIntegral <$> getWord16 >>= getExtensions else return [] return $ ServerHello ver random session cipherid compressionid exts @@ -249,8 +245,8 @@ decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest cp = do- certTypes <- map (fromJust . valToType . fromIntegral) <$> getWords8-+ mcertTypes <- map (valToType . fromIntegral) <$> getWords8+ certTypes <- mapM (fromJustM "decodeCertRequest") mcertTypes sigHashAlgs <- if cParamsVersion cp >= TLS12 then Just <$> (getWord16 >>= getSignatureHashAlgorithms) else return Nothing@@ -384,14 +380,14 @@ SKX_Unparsed bytes -> putBytes bytes _ -> error ("encodeHandshakeContent: cannot handle: " ++ show skg) -encodeHandshakeContent (HelloRequest) = return ()-encodeHandshakeContent (ServerHelloDone) = return ()+encodeHandshakeContent HelloRequest = return ()+encodeHandshakeContent ServerHelloDone = return () encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do putWords8 (map valOfType certTypes) case sigAlgs of Nothing -> return ()- Just l -> putWords16 $ map (\(x,y) -> (fromIntegral $ valOfType x) * 256 + (fromIntegral $ valOfType y)) l+ Just l -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l encodeCertAuthorities certAuthorities where -- Convert a distinguished name to its DER encoding. encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn@@ -399,7 +395,7 @@ -- Encode a list of distinguished names. encodeCertAuthorities certAuths = do enc <- mapM encodeCA certAuths- let totLength = sum $ map (((+) 2) . B.length) enc+ let totLength = sum $ map ((+) 2 . B.length) enc putWord16 (fromIntegral totLength) mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc @@ -455,8 +451,8 @@ getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm getSignatureHashAlgorithm = do- h <- fromJust . valToType <$> getWord8- s <- fromJust . valToType <$> getWord8+ h <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm"+ s <- (valToType <$> getWord8) >>= fromJustM "getSignatureHashAlgorithm" return (h,s) putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put@@ -544,11 +540,11 @@ getPRF ver ciph | ver < TLS12 = prf_MD5SHA1 | maybe True (< TLS12) (cipherMinVer ciph) = prf_SHA256- | otherwise = prf_TLS ver $ maybe SHA256 id $ cipherPRFHash ciph+ | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMasterSecret_SSL :: ByteArrayAccess preMaster => preMaster -> ClientRandom -> ServerRandom -> ByteString generateMasterSecret_SSL premasterSecret (ClientRandom c) (ServerRandom s) =- B.concat $ map (computeMD5) ["A","BB","CCC"]+ B.concat $ map computeMD5 ["A","BB","CCC"] where computeMD5 label = hash MD5 $ B.concat [ B.convert premasterSecret, computeSHA1 label ] computeSHA1 label = hash SHA1 $ B.concat [ label, B.convert premasterSecret, c, s ] @@ -647,3 +643,7 @@ encodeSignedECDHParams :: ServerECDHParams -> ClientRandom -> ServerRandom -> ByteString encodeSignedECDHParams dhparams cran sran = runPut $ putClientRandom32 cran >> putServerRandom32 sran >> putServerECDHParams dhparams++fromJustM :: Monad m => String -> Maybe a -> m a+fromJustM what Nothing = fail ("fromJust " ++ what ++ ": Nothing")+fromJustM _ (Just x) = return x
Network/TLS/Parameters.hs view
@@ -1,5 +1,3 @@- {-# LANGUAGE CPP #-}- -- | -- Module : Network.TLS.Parameters -- License : BSD-style@@ -21,6 +19,7 @@ , defaultParamsClient -- * Parameters , MaxFragmentEnum(..)+ , GroupUsage(..) , CertificateUsage(..) , CertificateRejectReason(..) ) where@@ -36,12 +35,9 @@ import Network.TLS.Credentials import Network.TLS.X509 import Network.TLS.RNG (Seed)+import Network.TLS.Imports import Data.Default.Class-import Data.ByteString (ByteString) import qualified Data.ByteString as B-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (mempty)-#endif type HostName = String @@ -116,8 +112,13 @@ -- messages. For TLS1.0, it should not be empty. , serverCACertificates :: [SignedCertificate] - -- | Server Optional Diffie Hellman parameters. If this value is not- -- properly set, no Diffie Hellman key exchange will take place.+ -- | Server Optional Diffie Hellman parameters. Setting parameters is+ -- necessary for FFDHE key exchange when clients are not compatible+ -- with RFC 7919.+ --+ -- Value can be one of the standardized groups from module+ -- "Network.TLS.Extra.FFDHE" or custom parameters generated with+ -- 'Crypto.PubKey.DH.generateParams'. , serverDHEParams :: Maybe DHParams , serverShared :: Shared@@ -186,10 +187,12 @@ -- 'False', empty packets will never be added, which is less secure, but might help in rare -- cases. , supportedEmptyPacket :: Bool- -- | A list of supported elliptic curves in the preferred order.- -- The default value is ['P256','P384','P521'].- -- 'P256' provides 128-bit security which is strong enough- -- until 2030 and is fast because its backend is written in C.+ -- | A list of supported elliptic curves and finite-field groups in the+ -- preferred order.+ -- The default value is ['X25519','P256','P384','P521'].+ -- 'X25519' and 'P256' provide 128-bit security which is strong+ -- enough until 2030. Both curves are fast because their+ -- backends are written in C. , supportedGroups :: [Group] } deriving (Show,Eq) @@ -212,7 +215,7 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True- , supportedGroups = [P256,P384,P521]+ , supportedGroups = [X25519,P256,P384,P521] } instance Default Supported where@@ -235,6 +238,21 @@ , sharedValidationCache = def } +-- | Group usage callback possible return values.+data GroupUsage =+ GroupUsageValid -- ^ usage of group accepted+ | GroupUsageInsecure -- ^ usage of group provides insufficient security+ | GroupUsageUnsupported String -- ^ usage of group rejected for other reason (specified as string)+ | GroupUsageInvalidPublic -- ^ usage of group with an invalid public value+ deriving (Show,Eq)++defaultGroupUsage :: DHParams -> DHPublic -> IO GroupUsage+defaultGroupUsage params public+ | even $ dhParamsGetP params = return $ GroupUsageUnsupported "invalid odd prime"+ | not $ dhValid params (dhParamsGetG params) = return $ GroupUsageUnsupported "invalid generator"+ | not $ dhValid params (dhUnwrapPublic public) = return GroupUsageInvalidPublic+ | otherwise = return GroupUsageValid+ -- | A set of callbacks run by the clients for various corners of TLS establishment data ClientHooks = ClientHooks { -- | This action is called when the server sends a@@ -267,6 +285,11 @@ -- | This action is called when the client sends ClientHello -- to determine ALPN values such as '["h2", "http/1.1"]'. , onSuggestALPN :: IO (Maybe [B.ByteString])+ -- | This action is called to validate DHE parameters when+ -- the server selected a finite-field group not part of+ -- the "Supported Groups Registry".+ -- See RFC 7919 section 3.1 for recommandations.+ , onCustomFFDHEGroup :: DHParams -> DHPublic -> IO GroupUsage } defaultClientHooks :: ClientHooks@@ -274,6 +297,7 @@ { onCertificateRequest = \ _ -> return Nothing , onServerCertificate = validateDefault , onSuggestALPN = return Nothing+ , onCustomFFDHEGroup = defaultGroupUsage } instance Show ClientHooks where
Network/TLS/Receiving.hs view
@@ -27,12 +27,13 @@ import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util+import Network.TLS.Imports processPacket :: Context -> Record Plaintext -> IO (Either TLSError Packet) processPacket _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment -processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` (decodeAlerts $ fragmentGetBytes fragment))+processPacket _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) processPacket ctx (Record ProtocolType_ChangeCipherSpec _ fragment) = case decodeChangeCipherSpec $ fragmentGetBytes fragment of@@ -41,7 +42,7 @@ return $ Right ChangeCipherSpec processPacket ctx (Record ProtocolType_Handshake ver fragment) = do- keyxchg <- getHState ctx >>= \hs -> return $ (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)+ keyxchg <- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange) usingState ctx $ do let currentParams = CurrentParams { cParamsVersion = ver@@ -53,7 +54,7 @@ hss <- parseMany currentParams mCont (fragmentGetBytes fragment) return $ Handshake hss where parseMany currentParams mCont bs =- case maybe decodeHandshakeRecord id mCont $ bs of+ case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> modify (\st -> st { stHandshakeRecordCont = Just cont }) >> return [] GotSuccess (ty,content) ->@@ -61,7 +62,7 @@ GotSuccessRemaining (ty,content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err- Right hh -> (hh:) `fmap` parseMany currentParams Nothing left+ Right hh -> (hh:) <$> parseMany currentParams Nothing left processPacket _ (Record ProtocolType_DeprecatedHandshake _ fragment) = case decodeDeprecatedHandshake $ fragmentGetBytes fragment of
Network/TLS/Record/Disengage.hs view
@@ -28,7 +28,7 @@ import Network.TLS.Util import Network.TLS.Wire import Network.TLS.Packet-import Data.ByteString (ByteString)+import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert) @@ -62,7 +62,7 @@ Just pad -> do cver <- getRecordVersion let b = B.length pad - 1- return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad)+ return (cver < TLS10 || B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad) unless (macValid &&! paddingValid) $ do throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)@@ -87,7 +87,7 @@ let minContent = (if explicitIV then bulkIVSize bulk else 0) + max (macSize + 1) blockSize -- check if we have enough bytes to cover the minimum for this cipher- when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) $ sanityCheckError+ when ((econtentLen `mod` blockSize) /= 0 || econtentLen < minContent) sanityCheckError {- update IV -} (iv, econtent') <- if explicitIV@@ -99,7 +99,7 @@ let paddinglength = fromIntegral (B.last content') + 1 let contentlen = B.length content' - paddinglength - macSize (content, mac, padding) <- get3 content' (contentlen, macSize, paddinglength)- getCipherData record $ CipherData+ getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Just padding@@ -107,14 +107,14 @@ decryptOf (BulkStateStream (BulkStream decryptF)) = do -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < macSize) $ sanityCheckError+ when (econtentLen < macSize) sanityCheckError let (content', bulkStream') = decryptF econtent {- update Ctx -} let contentlen = B.length content' - macSize (content, mac) <- get2 content' (contentlen, macSize) modify $ \txs -> txs { stCryptState = cst { cstKey = BulkStateStream bulkStream' } }- getCipherData record $ CipherData+ getCipherData record CipherData { cipherDataContent = content , cipherDataMAC = Just mac , cipherDataPadding = Nothing@@ -126,7 +126,7 @@ cipherLen = econtentLen - authTagLen - nonceExpLen -- check if we have enough bytes to cover the minimum for this cipher- when (econtentLen < (authTagLen + nonceExpLen)) $ sanityCheckError+ when (econtentLen < (authTagLen + nonceExpLen)) sanityCheckError (enonce, econtent', authTag) <- get3 econtent (nonceExpLen, cipherLen, authTagLen) let encodedSeq = encodeWord64 $ msSequence $ stMacState tst
Network/TLS/Record/Engage.hs view
@@ -13,7 +13,6 @@ ( engageRecord ) where -import Control.Applicative import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag(..)) @@ -24,7 +23,7 @@ import Network.TLS.Compression import Network.TLS.Wire import Network.TLS.Packet-import Data.ByteString (ByteString)+import Network.TLS.Imports import qualified Data.ByteString as B import qualified Data.ByteArray as B (convert)
Network/TLS/Record/State.hs view
@@ -24,8 +24,6 @@ , getMacSequence ) where -import Data.Word-import Control.Applicative import Control.Monad.State.Strict import Network.TLS.Compression import Network.TLS.Cipher@@ -36,8 +34,8 @@ import Network.TLS.Packet import Network.TLS.MAC import Network.TLS.Util+import Network.TLS.Imports -import Data.ByteString (ByteString) import qualified Data.ByteString as B data CryptState = CryptState
Network/TLS/Record/Types.hs view
@@ -39,10 +39,9 @@ ) where import Network.TLS.Struct+import Network.TLS.Imports import Network.TLS.Record.State-import Data.ByteString (ByteString) import qualified Data.ByteString as B-import Control.Applicative ((<$>)) -- | Represent a TLS record. data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)
Network/TLS/Sending.hs view
@@ -10,12 +10,10 @@ -- module Network.TLS.Sending (writePacket) where -import Control.Applicative import Control.Monad.State.Strict import Control.Concurrent.MVar import Data.IORef -import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Types (Role(..))@@ -29,6 +27,7 @@ import Network.TLS.Handshake.State import Network.TLS.Cipher import Network.TLS.Util+import Network.TLS.Imports -- | 'makePacketData' create a Header and a content bytestring related to a packet -- this doesn't change any state@@ -38,7 +37,7 @@ return $ Record (packetType pkt) ver (fragmentPlaintext $ writePacketContent pkt) where writePacketContent (Handshake hss) = encodeHandshakes hss writePacketContent (Alert a) = encodeAlerts a- writePacketContent (ChangeCipherSpec) = encodeChangeCipherSpec+ writePacketContent ChangeCipherSpec = encodeChangeCipherSpec writePacketContent (AppData x) = x -- | marshall packet data@@ -70,7 +69,7 @@ prepareRecord ctx f = do ver <- usingState_ ctx (getVersionWithDefault $ maximum $ supportedVersions $ ctxSupported ctx) txState <- readMVar $ ctxTxState ctx- let sz = case stCipher $ txState of+ let sz = case stCipher txState of Nothing -> 0 Just cipher -> if hasRecordIV $ bulkF $ cipherBulk cipher then bulkIVSize $ cipherBulk cipher
Network/TLS/State.hs view
@@ -57,7 +57,6 @@ import Network.TLS.Types (Role(..)) import Network.TLS.Wire (GetContinuation) import Network.TLS.Extension-import Data.ByteString (ByteString) import qualified Data.ByteString as B import Control.Monad.State.Strict import Network.TLS.ErrT@@ -174,10 +173,10 @@ Just _ -> st getVersion :: TLSSt Version-getVersion = maybe (error $ "internal error: version hasn't been set yet") id <$> gets stVersion+getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion getVersionWithDefault :: Version -> TLSSt Version-getVersionWithDefault defaultVer = maybe defaultVer id <$> gets stVersion+getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion setSecureRenegotiation :: Bool -> TLSSt () setSecureRenegotiation b = modify (\st -> st { stSecureRenegotiation = b })
Network/TLS/Struct.hs view
@@ -60,9 +60,7 @@ , typeOfHandshake ) where -import Data.ByteString (ByteString) import qualified Data.ByteString as B (length)-import Data.Word import Data.X509 (CertificateChain, DistinguishedName) import Data.Typeable import Control.Exception (Exception(..))@@ -328,16 +326,16 @@ packetType (AppData _) = ProtocolType_AppData typeOfHandshake :: Handshake -> HandshakeType-typeOfHandshake (ClientHello {}) = HandshakeType_ClientHello-typeOfHandshake (ServerHello {}) = HandshakeType_ServerHello-typeOfHandshake (Certificates {}) = HandshakeType_Certificate-typeOfHandshake HelloRequest = HandshakeType_HelloRequest-typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone-typeOfHandshake (ClientKeyXchg {}) = HandshakeType_ClientKeyXchg-typeOfHandshake (ServerKeyXchg {}) = HandshakeType_ServerKeyXchg-typeOfHandshake (CertRequest {}) = HandshakeType_CertRequest-typeOfHandshake (CertVerify {}) = HandshakeType_CertVerify-typeOfHandshake (Finished {}) = HandshakeType_Finished+typeOfHandshake ClientHello{} = HandshakeType_ClientHello+typeOfHandshake ServerHello{} = HandshakeType_ServerHello+typeOfHandshake Certificates{} = HandshakeType_Certificate+typeOfHandshake HelloRequest = HandshakeType_HelloRequest+typeOfHandshake ServerHelloDone = HandshakeType_ServerHelloDone+typeOfHandshake ClientKeyXchg{} = HandshakeType_ClientKeyXchg+typeOfHandshake ServerKeyXchg{} = HandshakeType_ServerKeyXchg+typeOfHandshake CertRequest{} = HandshakeType_CertRequest+typeOfHandshake CertVerify{} = HandshakeType_CertVerify+typeOfHandshake Finished{} = HandshakeType_Finished numericalVer :: Version -> (Word8, Word8) numericalVer SSL2 = (2, 0)
Network/TLS/Types.hs view
@@ -16,8 +16,7 @@ , Direction(..) ) where -import Data.ByteString (ByteString)-import Data.Word+import Network.TLS.Imports type HostName = String
Network/TLS/Util.hs view
@@ -12,10 +12,8 @@ , catchException ) where -import Data.List (foldl')--- import Network.TLS.Imports (ByteString)-import Data.ByteString (ByteString) import qualified Data.ByteString as B+import Network.TLS.Imports import Control.Exception (SomeException) import Control.Concurrent.Async
Network/TLS/Util/ASN1.hs view
@@ -12,10 +12,10 @@ , encodeASN1Object ) where +import Network.TLS.Imports import Data.ASN1.Types (fromASN1, toASN1, ASN1Object) import Data.ASN1.Encoding (decodeASN1', encodeASN1') import Data.ASN1.BinaryEncoding (DER(..))-import Data.ByteString (ByteString) -- | Attempt to decode a bytestring representing -- an DER ASN.1 serialized object into the object.
Network/TLS/Wire.hs view
@@ -54,13 +54,9 @@ import Data.Serialize.Get hiding (runGet) import qualified Data.Serialize.Get as G import Data.Serialize.Put-import Control.Applicative ((<$>))-import Control.Monad-import Data.ByteString (ByteString) import qualified Data.ByteString as B-import Data.Word-import Data.Bits import Network.TLS.Struct+import Network.TLS.Imports import Network.TLS.Util.Serialization type GetContinuation a = ByteString -> GetResult a@@ -125,12 +121,12 @@ getBigNum16 :: Get BigNum getBigNum16 = BigNum <$> getOpaque16 -getList :: Int -> (Get (Int, a)) -> Get [a]+getList :: Int -> Get (Int, a) -> Get [a] getList totalLen getElement = isolate totalLen (getElements totalLen) where getElements len | len < 0 = error "list consumed too much data. should never happen with isolate." | len == 0 = return []- | otherwise = getElement >>= \(elementLen, a) -> liftM ((:) a) (getElements (len - elementLen))+ | otherwise = getElement >>= \(elementLen, a) -> (:) a <$> getElements (len - elementLen) processBytes :: Int -> Get a -> Get a processBytes i f = isolate i f@@ -148,7 +144,7 @@ putWords16 :: [Word16] -> Put putWords16 l = do- putWord16 $ 2 * (fromIntegral $ length l)+ putWord16 $ 2 * fromIntegral (length l) mapM_ putWord16 l putWord24 :: Int -> Put
Network/TLS/X509.hs view
@@ -53,7 +53,7 @@ wrapCertificateChecks :: [FailedReason] -> CertificateUsage wrapCertificateChecks [] = CertificateUsageAccept wrapCertificateChecks l- | Expired `elem` l = CertificateUsageReject $ CertificateRejectExpired- | InFuture `elem` l = CertificateUsageReject $ CertificateRejectExpired- | UnknownCA `elem` l = CertificateUsageReject $ CertificateRejectUnknownCA+ | Expired `elem` l = CertificateUsageReject CertificateRejectExpired+ | InFuture `elem` l = CertificateUsageReject CertificateRejectExpired+ | UnknownCA `elem` l = CertificateUsageReject CertificateRejectUnknownCA | otherwise = CertificateUsageReject $ CertificateRejectOther (show l)
Tests/Ciphers.hs view
@@ -13,13 +13,13 @@ import Network.TLS.Extra.Cipher arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (fromIntegral $ bulkKeySize bulk)+arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString-arbitraryIV bulk = B.pack `fmap` vector (fromIntegral $ bulkIVSize bulk)+arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) arbitraryText :: Bulk -> Gen B.ByteString-arbitraryText bulk = B.pack `fmap` vector (fromIntegral $ bulkBlockSize bulk)+arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString deriving (Show,Eq)
Tests/Connection.hs view
@@ -9,6 +9,7 @@ , arbitraryPairParams , arbitraryPairParamsWithVersionsAndCiphers , arbitraryClientCredential+ , isCustomDHParams , leafPublicKey , oneSessionManager , setPairParamsSessionManager@@ -77,8 +78,10 @@ arbitraryHashSignatures :: Gen [HashAndSignatureAlgorithm] arbitraryHashSignatures = sublistOf knownHashSignatures -knownGroups :: [Group]-knownGroups = [P256,P384,P521,X25519,X448]+knownGroups, knownECGroups, knownFFGroups :: [Group]+knownECGroups = [P256,P384,P521,X25519,X448]+knownFFGroups = [FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192]+knownGroups = knownECGroups ++ knownFFGroups arbitraryGroups :: Gen [Group] arbitraryGroups = listOf1 $ elements knownGroups@@ -94,6 +97,9 @@ , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) ] +isCustomDHParams :: DHParams -> Bool+isCustomDHParams params = params == dhParams+ leafPublicKey :: CertificateChain -> Maybe PubKey leafPublicKey (CertificateChain []) = Nothing leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf)@@ -102,7 +108,7 @@ arbitraryCipherPair connectVersion = do serverCiphers <- arbitraryCiphers `suchThat` (\cs -> or [maybe True (<= connectVersion) (cipherMinVer x) | x <- cs])- clientCiphers <- oneof [arbitraryCiphers] `suchThat`+ clientCiphers <- arbitraryCiphers `suchThat` (\cs -> or [x `elem` serverCiphers && maybe True (<= connectVersion) (cipherMinVer x) | x <- cs]) return (clientCiphers, serverCiphers)@@ -118,11 +124,11 @@ serAllowedVersions <- (:[]) `fmap` elements allowedVersions arbitraryPairParamsWithVersionsAndCiphers (allowedVersions, serAllowedVersions) (clientCiphers, serverCiphers) -arbitraryGroupPair :: Gen ([Group], [Group])-arbitraryGroupPair = do- serverGroups <- arbitraryGroups- clientGroups <- oneof [arbitraryGroups] `suchThat`- (\gs -> or [x `elem` serverGroups | x <- gs])+arbitraryECGroupPair :: Gen ([Group], [Group])+arbitraryECGroupPair = do+ let arbitraryECGroups = listOf1 $ elements knownECGroups+ serverGroups <- arbitraryECGroups+ clientGroups <- arbitraryECGroups `suchThat` any (`elem` serverGroups) return (clientGroups, serverGroups) arbitraryHashSignaturePair :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm])@@ -139,7 +145,7 @@ dhparams <- elements [dhParams,ffdhe2048,ffdhe3072] creds <- arbitraryCredentialsOfEachType- (clientGroups, serverGroups) <- arbitraryGroupPair+ (clientGroups, serverGroups) <- arbitraryECGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def { serverSupported = def { supportedCiphers = serverCiphers
Tests/Tests.hs view
@@ -170,19 +170,26 @@ serverVersions = [TLS12] ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 , cipher_ECDHE_RSA_AES128CBC_SHA+ , cipher_DHE_RSA_AES256GCM_SHA384+ , cipher_DHE_RSA_AES128_SHA1 ] (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (ciphers, ciphers) clientGroups <- pick arbitraryGroups serverGroups <- pick arbitraryGroups- let clientParam' = clientParam { clientSupported = (clientSupported clientParam)+ denyCustom <- pick arbitrary+ let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid+ clientParam' = clientParam { clientSupported = (clientSupported clientParam) { supportedGroups = clientGroups }+ , clientHooks = (clientHooks clientParam)+ { onCustomFFDHEGroup = \_ _ -> return groupUsage } } serverParam' = serverParam { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups } }- shouldFail = null (clientGroups `intersect` serverGroups)+ isCustom = maybe True isCustomDHParams (serverDHEParams serverParam')+ shouldFail = null (clientGroups `intersect` serverGroups) && isCustom && denyCustom if shouldFail then runTLSInitFailure (clientParam',serverParam') else runTLSPipeSimple (clientParam',serverParam')
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 1.4.0+Version: 1.4.1 Description: Native Haskell TLS and SSL protocol implementation for server and client. .