diff --git a/examples/clcertClient.hs b/examples/clcertClient.hs --- a/examples/clcertClient.hs +++ b/examples/clcertClient.hs @@ -16,7 +16,7 @@ main = do d : _ <- getArgs rk <- readKey $ d ++ "/yoshikuni.sample_key" - rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt" + rc <- readCertificateChain [d ++ "/yoshikuni.sample_crt"] ca <- readCertificateStore [d ++ "/cacert.pem"] h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG diff --git a/examples/clcertEcdsaClient.hs b/examples/clcertEcdsaClient.hs --- a/examples/clcertEcdsaClient.hs +++ b/examples/clcertEcdsaClient.hs @@ -16,9 +16,9 @@ main = do d : _ <- getArgs rk <- readKey $ d ++ "/yoshikuni.sample_key" - rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt" + rc <- readCertificateChain [d ++ "/yoshikuni.sample_crt"] ek <- readKey $ d ++ "/client_ecdsa.sample_key" - ec <- readCertificateChain $ d ++ "/client_ecdsa.sample_crt" + ec <- readCertificateChain [d ++ "/client_ecdsa.sample_crt"] ca <- readCertificateStore [d ++ "/cacert.pem"] h <- connectTo "localhost" $ PortNumber 443 g <- cprgCreate <$> createEntropyPool :: IO SystemRNG diff --git a/examples/clcertServer.hs b/examples/clcertServer.hs --- a/examples/clcertServer.hs +++ b/examples/clcertServer.hs @@ -18,7 +18,7 @@ main = do d : _ <- getArgs k <- readKey $ d ++ "/localhost.sample_key" - c <- readCertificateChain $ d ++"/localhost.sample_crt" + c <- readCertificateChain [d ++"/localhost.sample_crt"] ca <- readCertificateStore [d ++ "/cacert.pem"] g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG soc <- listenOn $ PortNumber 443 diff --git a/examples/debugServer.hs b/examples/debugServer.hs --- a/examples/debugServer.hs +++ b/examples/debugServer.hs @@ -18,7 +18,7 @@ main = do d : _ <- getArgs k <- readKey $ d ++ "/localhost.sample_key" - c <- readCertificateChain $ d ++ "/localhost.sample_crt" + c <- readCertificateChain [d ++ "/localhost.sample_crt"] g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG soc <- listenOn $ PortNumber 443 void . (`runStateT` g0) . forever $ do diff --git a/examples/eccServer.hs b/examples/eccServer.hs --- a/examples/eccServer.hs +++ b/examples/eccServer.hs @@ -29,9 +29,9 @@ main = do d : _ <- getArgs rk <- readKey $ d ++ "/localhost.sample_key" - rc <- readCertificateChain $ d ++ "/localhost.sample_crt" + rc <- readCertificateChain [d ++ "/localhost.sample_crt"] ek <- readKey $ d ++ "/localhost_ecdsa.sample_key" - ec <- readCertificateChain $ d ++ "/localhost_ecdsa.sample_crt" + ec <- readCertificateChain [d ++ "/localhost_ecdsa.sample_crt"] g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG soc <- listenOn $ PortNumber 443 void . (`runStateT` g0) . forever $ do diff --git a/examples/renegServer.hs b/examples/renegServer.hs --- a/examples/renegServer.hs +++ b/examples/renegServer.hs @@ -18,7 +18,7 @@ main = do d : _ <- getArgs k <- readKey $ d ++ "/localhost.sample_key" - c <- readCertificateChain $ d ++ "/localhost.sample_crt" + c <- readCertificateChain [d ++ "/localhost.sample_crt"] g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG soc <- listenOn $ PortNumber 443 void . (`runStateT` g0) . forever $ do diff --git a/examples/simpleServer.hs b/examples/simpleServer.hs --- a/examples/simpleServer.hs +++ b/examples/simpleServer.hs @@ -18,7 +18,7 @@ main = do d : _ <- getArgs k <- readKey $ d ++ "/localhost.sample_key" - c <- readCertificateChain $ d ++ "/localhost.sample_crt" + c <- readCertificateChain [d ++ "/localhost.sample_crt"] g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG soc <- listenOn $ PortNumber 443 void . (`runStateT` g0) . forever $ do diff --git a/peyotls.cabal b/peyotls.cabal --- a/peyotls.cabal +++ b/peyotls.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: peyotls -version: 0.0.0.21 +version: 0.0.0.22 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -33,11 +33,15 @@ . * TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256 . + implement the following curves + . + * SEC p256r1 + . And support client certificate with the following algorithms. . - * RSA (SHA1 or SHA256 depending on the agreed cipher suite) + * RSA with SHA256 . - * ECDSA (SHA1 or SHA256 depending on the agreed cipher suite) + * ECDSA with SHA256 . And support secure renegotiation (RFC 5746) . @@ -45,6 +49,8 @@ . * session resumption (RFC 5077) . + * curves other than SEC p256r1 + . Server sample . * file: examples/simpleServer.hs @@ -85,7 +91,7 @@ > main :: IO () > main = do > k <- readKey "localhost.key" - > c <- readCertificateChain "localhost.crt" + > c <- readCertificateChain ["localhost.crt"] > g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG > soc <- listenOn $ PortNumber 443 > void . (`runStateT` g0) . forever $ do @@ -172,7 +178,7 @@ > % diff examples/simpleClient.hs examples/clcertClient.hs > 15a16,17 > > rk <- readKey "client_rsa.key" - > > rc <- readCertificateChain "client_rsa.crt" + > > rc <- readCertificateChain ["client_rsa.crt"] > 20c22 > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca > --- @@ -185,7 +191,7 @@ > % diff examples/clcertClient.hs examples/clcertEcdsaClient.hs > 17a18,19 > > ek <- readKey "client_ecdsa.key" - > > ec <- readCertificateChain "client_ecdsa.crt" + > > ec <- readCertificateChain ["client_ecdsa.crt"] > 22c24 > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca > --- @@ -210,12 +216,12 @@ > > > 18,19c29,32 > < k <- readKey "localhost.key" - > < c <- readCertificateChain "localhost.crt" + > < c <- readCertificateChain ["localhost.crt"] > --- > > rk <- readKey "localhost.key" - > > rc <- readCertificateChain "localhost.crt" + > > rc <- readCertificateChain ["localhost.crt"] > > ek <- readKey "localhost_ecdsa.key" - > > ec <- readCertificateChain "localhost_ecdsa.crt" + > > ec <- readCertificateChain ["localhost_ecdsa.crt"] > 26c39 > < p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)] > --- @@ -274,7 +280,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.0.0.21 + tag: peyotls-0.0.0.22 library hs-source-dirs: src diff --git a/src/Network/PeyoTLS/Base.hs b/src/Network/PeyoTLS/Base.hs --- a/src/Network/PeyoTLS/Base.hs +++ b/src/Network/PeyoTLS/Base.hs @@ -3,11 +3,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.PeyoTLS.Base ( Extension(..), + makeEcdsaPubKey, + ClSignPublicKey(..), ClSignSecretKey(..), + SvSignPublicKey(..), PeyotlsM, eRenegoInfo, debug, generateKs, blindSign, HM.CertSecretKey(..), isEcdsaKey, isRsaKey, HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM, HM.withRandom, HM.randomByteString, - HM.TlsHandle, HM.names, + HM.TlsHandle_, HM.names, readHandshake, getChangeCipherSpec, writeHandshake, putChangeCipherSpec, writeHandshakeNH, @@ -19,7 +22,7 @@ CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), HM.getCipherSuite, HM.setCipherSuite, - CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..), + CertReq(..), certificateRequest, ClientCertificateType(..), SecretKey(..), ClientKeyExchange(..), Epms(..), HM.generateKeys, HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite, @@ -27,6 +30,8 @@ HM.Side(..), HM.RW(..), finishedHash, DhParam(..), dh3072Modp, secp256r1, HM.throwError, HM.getClientFinished, HM.getServerFinished, + checkClientRenego, makeClientRenego, + checkServerRenego, makeServerRenego, Finished(..), HM.ContentType(CTAlert, CTHandshake, CTAppData), Handshake(..), @@ -34,10 +39,13 @@ hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_, hlGetContentRn, - HM.getSettings, HM.setSettings, + HM.getSettings, HM.setSettings, HM.SettingsS, + getSettingsC, setSettingsC, HM.flushAppData_, flushAppData, HM.pushAdBufH, + + validateAlert, ) where import Control.Applicative @@ -66,14 +74,19 @@ import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.Types.PubKey.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Data.X509 as X509 +import qualified Data.X509.Validation as X509 +import qualified Data.X509.CertificateStore as X509 + import Network.PeyoTLS.Types ( Extension(..), Handshake(..), HandshakeItem(..), ClientHello(..), ServerHello(..), SessionId(..), CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertificateRequest(..), certificateRequest, ClientCertificateType(..), + CertReq(..), certificateRequest, ClientCertificateType(..), SignAlg(..), HashAlg(..), ServerHelloDone(..), ClientKeyExchange(..), Epms(..), DigitallySigned(..), Finished(..) ) @@ -81,7 +94,7 @@ TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, ValidateHandle(..), handshakeValidate, - TlsHandle(..), ContentType(..), + TlsHandle_(..), ContentType(..), names, getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, tlsGetContentType, tlsGet, tlsPut, tlsPutNH, @@ -95,7 +108,8 @@ getServerFinished, setServerFinished, resetSequenceNumber, - getSettings, setSettings, + getSettings, setSettings, SettingsS, + getSettingsC, setSettingsC, flushAppData_, getAdBuf, setAdBuf, @@ -182,52 +196,6 @@ encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad]) encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss) -class SecretKey sk where - type Blinder sk - generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g) - sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString - signatureAlgorithm :: sk -> SignAlg - -instance SecretKey RSA.PrivateKey where - type Blinder RSA.PrivateKey = RSA.Blinder - generateBlinder sk rng = - RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk - sign hs bl sk bs = let - (h, oid) = first ($ bs) $ case hs of - Sha1 -> (SHA1.hash, - ASN1.OID [1, 3, 14, 3, 2, 26]) - Sha256 -> (SHA256.hash, - ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) - _ -> error $ "HandshakeBase: " ++ - "not implemented bulk encryption type" - a = [ASN1.Start ASN1.Sequence, - ASN1.Start ASN1.Sequence, - oid, ASN1.Null, ASN1.End ASN1.Sequence, - ASN1.OctetString h, ASN1.End ASN1.Sequence] - b = ASN1.encodeASN1' ASN1.DER a - pd = BS.concat [ "\x00\x01", - BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ] - ps = RSA.public_size $ RSA.private_pub sk in - RSA.dp (Just bl) sk pd - signatureAlgorithm _ = Rsa - -instance SecretKey ECDSA.PrivateKey where - type Blinder ECDSA.PrivateKey = Integer - generateBlinder _ rng = let - (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in - (bl, rng') - sign ha bl sk = B.encode . - (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id) - where - (hs, bls) = case ha of - Sha1 -> (SHA1.hash, 64) - Sha256 -> (SHA256.hash, 64) - _ -> error $ "HandshakeBase: " ++ - "not implemented bulk encryption type" - q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk - x = ECDSA.private_d sk - signatureAlgorithm _ = Ecdsa - class DhParam b where type Secret b type Public b @@ -289,9 +257,9 @@ HM.Server -> HM.setServerFinished fh return fh -instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where - type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g - type DebugLevel (HM.TlsHandle h g) = DebugLevel h +instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle_ h g) where + type HandleMonad (HM.TlsHandle_ h g) = HM.TlsM h g + type DebugLevel (HM.TlsHandle_ h g) = DebugLevel h hlPut = HM.hlPut_ hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet__ . (, undefined) @@ -300,13 +268,13 @@ hlDebug = HM.hlDebug_ hlClose = HM.hlClose_ -checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g -> +checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle_ h g -> HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString checkAppData t m = m >>= \cp -> case cp of (HM.CTAppData, ad) -> return ad (HM.CTAlert, "\SOH\NUL") -> do _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL" - E.throwError "TlsHandle.checkAppData: EOF" + E.throwError "TlsHandle_.checkAppData: EOF" (HM.CTHandshake, hs) -> do lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n" lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack @@ -315,20 +283,20 @@ . (++ "\n") $ show (B.decode hs :: Either String Handshake) return "" _ -> do _ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10" - E.throwError "TlsHandle.checkAppData: not application data" + E.throwError "TlsHandle_.checkAppData: not application data" -hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) -> - HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString +hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> + HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh . (, undefined) hlGetLineRn_, hlGetContentRn_ :: (HM.ValidateHandle h, CPRG g) => - (HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString + (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString hlGetLineRn_ rh = ($) <$> checkAppData <*> HM.tGetLine_ rh hlGetContentRn_ rh = ($) <$> checkAppData <*> HM.tGetContent_ rh -hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) -> - HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString +hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> + HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString hlGetRn rn t n = do bf <- HM.getAdBuf t if BS.length bf >= n @@ -338,7 +306,7 @@ else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf) hlGetLineRn :: (HM.ValidateHandle h, CPRG g) => - (HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> + (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString hlGetLineRn rn t = do bf <- HM.getAdBuf t @@ -361,8 +329,8 @@ _ -> bs hlGetContentRn :: (HM.ValidateHandle h, CPRG g) => - (HM.TlsHandle h g -> HM.TlsM h g ()) -> - HM.TlsHandle h g -> HM.TlsM h g BS.ByteString + (HM.TlsHandle_ h g -> HM.TlsM h g ()) -> + HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString hlGetContentRn rn t = do bf <- HM.getAdBuf t if BS.null bf @@ -384,3 +352,161 @@ eRenegoInfo :: Extension -> Maybe BS.ByteString eRenegoInfo (ERenegoInfo ri) = Just ri eRenegoInfo _ = Nothing + +checkClientRenego, checkServerRenego :: + HandleLike h => BS.ByteString -> HM.HandshakeM h g () +checkClientRenego cf = (cf ==) `liftM` HM.getClientFinished >>= \ok -> + E.unless ok . HM.throwError HM.ALFatal HM.ADHsFailure $ + "Network.PeyoTLS.Base.checkClientRenego: bad renegotiation" +checkServerRenego ri = do + cf <- HM.getClientFinished + sf <- HM.getServerFinished + E.unless (ri == cf `BS.append` sf) $ HM.throwError + HM.ALFatal HM.ADHsFailure + "Network.PeyoTLS.Base.checkServerRenego: bad renegotiation" + +makeClientRenego, makeServerRenego :: HandleLike h => HM.HandshakeM h g Extension +makeClientRenego = ERenegoInfo `liftM` HM.getClientFinished +makeServerRenego = ERenegoInfo `liftM` + (BS.append `liftM` HM.getClientFinished `E.ap` HM.getServerFinished) + +validateAlert :: [X509.FailedReason] -> HM.AlertDesc +validateAlert vr + | X509.UnknownCA `elem` vr = HM.ADUnknownCa + | X509.Expired `elem` vr = HM.ADCertificateExpired + | X509.InFuture `elem` vr = HM.ADCertificateExpired + | otherwise = HM.ADCertificateUnknown + +type SettingsC = ( + [CipherSuite], + [(HM.CertSecretKey, X509.CertificateChain)], + X509.CertificateStore ) + +getSettingsC :: HandleLike h => HM.HandshakeM h g SettingsC +getSettingsC = do + (css, crts, mcs) <- HM.getSettingsC + case mcs of + Just cs -> return (css, crts, cs) + _ -> HM.throwError HM.ALFatal HM.ADInternalError + "Network.PeyoTLS.Base.getSettingsC" + +setSettingsC :: HandleLike h => SettingsC -> HM.HandshakeM h g () +setSettingsC (css, crts, cs) = HM.setSettingsC (css, crts, Just cs) + +moduleName :: String +moduleName = "Network.PeyoTLS.Base" + +decodePoint :: BS.ByteString -> ECC.Point +decodePoint s = case BS.uncons s of + Just (4, p) -> let (x, y) = BS.splitAt 32 p in ECC.Point + (either error id $ B.decode x) + (either error id $ B.decode y) + _ -> error $ moduleName ++ ".decodePoint: not implemented point" + +class SvSignPublicKey pk where + svpAlgorithm :: pk -> SignAlg + verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool + +instance SvSignPublicKey RSA.PublicKey where + svpAlgorithm _ = Rsa + verify = rsaVerify + +rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool +rsaVerify ha pk sn m = let + (hs, oid0) = case ha of + Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26]) + Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) + _ -> error "not implemented" + (o, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail + . BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of + Right [ASN1.Start ASN1.Sequence, + ASN1.Start ASN1.Sequence, oid_, ASN1.Null, ASN1.End ASN1.Sequence, + ASN1.OctetString o_, ASN1.End ASN1.Sequence ] -> (o_, oid_) + e -> error $ show e in + oid == oid0 && o == hs m + +instance SvSignPublicKey ECDSA.PublicKey where + svpAlgorithm _ = Ecdsa + verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode + verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode + verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented" + +class SecretKey sk where + type Blinder sk + generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g) + sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString + signatureAlgorithm :: sk -> SignAlg + +instance SecretKey RSA.PrivateKey where + type Blinder RSA.PrivateKey = RSA.Blinder + generateBlinder sk rng = + RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk + sign hs bl sk bs = let + (h, oid) = first ($ bs) $ case hs of + Sha1 -> (SHA1.hash, + ASN1.OID [1, 3, 14, 3, 2, 26]) + Sha256 -> (SHA256.hash, + ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) + _ -> error $ "HandshakeBase: " ++ + "not implemented bulk encryption type" + a = [ASN1.Start ASN1.Sequence, + ASN1.Start ASN1.Sequence, + oid, ASN1.Null, ASN1.End ASN1.Sequence, + ASN1.OctetString h, ASN1.End ASN1.Sequence] + b = ASN1.encodeASN1' ASN1.DER a + pd = BS.concat [ "\x00\x01", + BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ] + ps = RSA.public_size $ RSA.private_pub sk in + RSA.dp (Just bl) sk pd + signatureAlgorithm _ = Rsa + +instance SecretKey ECDSA.PrivateKey where + type Blinder ECDSA.PrivateKey = Integer + generateBlinder _ rng = let + (Right bl, rng') = first B.decode $ cprgGenerate 32 rng in + (bl, rng') + sign ha bl sk = B.encode . + (($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id) + where + (hs, bls) = case ha of + Sha1 -> (SHA1.hash, 64) + Sha256 -> (SHA256.hash, 64) + _ -> error $ "HandshakeBase: " ++ + "not implemented bulk encryption type" + q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk + x = ECDSA.private_d sk + signatureAlgorithm _ = Ecdsa + +class ClSignSecretKey sk where + csSign :: sk -> BS.ByteString -> BS.ByteString + csAlgorithm :: sk -> (HashAlg, SignAlg) + +instance ClSignSecretKey RSA.PrivateKey where + csSign sk m = let pd = HM.rsaPadding (RSA.private_pub sk) m in RSA.dp Nothing sk pd + csAlgorithm _ = (Sha256, Rsa) + +instance ClSignSecretKey ECDSA.PrivateKey where + csSign sk m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m + where + q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk + x = ECDSA.private_d sk + enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [ + ASN1.Start ASN1.Sequence, + ASN1.IntVal r, ASN1.IntVal s, + ASN1.End ASN1.Sequence] + csAlgorithm _ = (Sha256, Ecdsa) + +class ClSignPublicKey pk where + cspAlgorithm :: pk -> SignAlg + csVerify :: pk -> BS.ByteString -> BS.ByteString -> Bool + +instance ClSignPublicKey RSA.PublicKey where + cspAlgorithm _ = Rsa + csVerify k s h = RSA.ep k s == HM.rsaPadding k h + +instance ClSignPublicKey ECDSA.PublicKey where + cspAlgorithm _ = Ecdsa + csVerify k = ECDSA.verify id k . either error id . B.decode + +makeEcdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey +makeEcdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ decodePoint xy diff --git a/src/Network/PeyoTLS/Certificate.hs b/src/Network/PeyoTLS/Certificate.hs --- a/src/Network/PeyoTLS/Certificate.hs +++ b/src/Network/PeyoTLS/Certificate.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.PeyoTLS.Certificate ( - CertificateRequest(..), certificateRequest, ClientCertificateType(..), + CertReq(..), certificateRequest, ClientCertificateType(..), ClientKeyExchange(..), DigitallySigned(..)) where import Control.Applicative ((<$>), (<*>)) @@ -25,7 +25,7 @@ . (\(X509.CertificateChainRaw ccr) -> ccr) . X509.encodeCertificateChain . (\(X509.CertificateChain cs) -> - X509.CertificateChain $ reverse cs) + X509.CertificateChain $ cs) instance B.Parsable X509.CertificateChain where parse = do @@ -33,29 +33,26 @@ (flip B.list (B.take =<< B.take 3) =<< B.take 3) case ecc of Right (X509.CertificateChain cs) -> - return . X509.CertificateChain $ reverse cs + return . X509.CertificateChain $ cs Left (n, err) -> fail $ show n ++ " " ++ err -data CertificateRequest - = CertificateRequest [ClientCertificateType] - [(HashAlg, SignAlg)] [X509.DistinguishedName] - | CertificateRequestRaw BS.ByteString +data CertReq = CertReq [ClientCertificateType] [(HashAlg, SignAlg)] [X509.DistinguishedName] deriving Show certificateRequest :: [ClientCertificateType] -> [(HashAlg, SignAlg)] -> - X509.CertificateStore -> CertificateRequest -certificateRequest t a = CertificateRequest t a + X509.CertificateStore -> CertReq +certificateRequest t a = CertReq t a . map (X509.certIssuerDN . X509.signedObject . X509.getSigned) . X509.listCertificates -instance B.Bytable CertificateRequest where - encode (CertificateRequest t a n) = BS.concat [ +instance B.Bytable CertReq where + encode (CertReq t a n) = BS.concat [ B.addLen w8 $ cmap B.encode t, B.addLen w16 . BS.concat $ concatMap (\(h, s) -> [B.encode h, B.encode s]) a, B.addLen w16 . flip cmap n $ B.addLen w16 . ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ] - encode (CertificateRequestRaw bs) = bs +-- encode (CertReq bs) = bs decode = B.evalBytableM $ do t <- flip B.list (B.take 1) =<< B.take 1 a <- flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2 @@ -64,7 +61,7 @@ a1 <- either (fail . show) return $ ASN1.decodeASN1' ASN1.DER bs either (fail . show) (return . fst) $ ASN1.fromASN1 a1 - return $ CertificateRequest t a n + return $ CertReq t a n data ClientCertificateType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq) diff --git a/src/Network/PeyoTLS/Client.hs b/src/Network/PeyoTLS/Client.hs --- a/src/Network/PeyoTLS/Client.hs +++ b/src/Network/PeyoTLS/Client.hs @@ -1,200 +1,179 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, - PackageImports, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Client ( - PeyotlsM, PeyotlsHandleC, - TlsM, TlsHandleC, - run, open, renegotiate, names, + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names, CipherSuite(..), KeyEx(..), BulkEnc(..), - ValidateHandle(..), CertSecretKey ) where + ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (first) -import Control.Monad (when, unless, liftM) +import Control.Monad (when, unless, liftM, ap) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG, SystemRNG) -import qualified "monads-tf" Control.Monad.Error as E -import qualified "monads-tf" Control.Monad.Error.Class as E import qualified Data.ByteString as BS -import qualified Data.ASN1.Types as ASN1 -import qualified Data.ASN1.Encoding as ASN1 -import qualified Data.ASN1.BinaryEncoding as ASN1 import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.PubKey.DH as DH -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.Prim as RSA import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.Base as HB -import Network.PeyoTLS.Base ( flushAppData, - Extension(..), getClientFinished, - getSettings, setSettings, - getClientFinished, getServerFinished, - PeyotlsM, - TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, - CertSecretKey(..), - withRandom, randomByteString, - TlsHandle, - readHandshake, getChangeCipherSpec, - writeHandshake, putChangeCipherSpec, - ValidateHandle(..), handshakeValidate, - ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..), - ClientHello(..), ServerHello(..), SessionId(..), +import qualified Network.PeyoTLS.Base as BASE (names) +import Network.PeyoTLS.Base ( debug, + PeyotlsM, TlsM, run, + getSettingsC, setSettingsC, + hlGetRn, hlGetLineRn, hlGetContentRn, + HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, randomByteString, flushAppData, + AlertLevel(..), AlertDesc(..), throwError, + ValidateHandle(..), handshakeValidate, validateAlert, + TlsHandle_, CertSecretKey(..), + readHandshake, writeHandshake, + getChangeCipherSpec, putChangeCipherSpec, + ClientHello(..), ServerHello(..), SessionId(..), eRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), setCipherSuite, - CertificateRequest(..), ClientCertificateType(..), - ClientKeyExchange(..), Epms(..), - generateKeys, encryptRsa, rsaPadding, - DigitallySigned(..), handshakeHash, flushCipherSuite, - Side(..), RW(..), finishedHash, - DhParam(..), generateKs, blindSign, + checkServerRenego, makeClientRenego, + ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..), + CertReq(..), ClientCertificateType(..), + ServerHelloDone(..), + ClientKeyExchange(..), Epms(..), generateKeys, encryptRsa, + DigitallySigned(..), ClSignSecretKey(..), handshakeHash, + Side(..), RW(..), finishedHash, flushCipherSuite, + DhParam(..), makeEcdsaPubKey ) - hlGetRn, hlGetLineRn, hlGetContentRn, - ) +type PeyotlsHandle = TlsHandle Handle SystemRNG -names :: TlsHandleC h g -> [String] -names = HB.names . tlsHandleC +newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandle_ h g } deriving Show +instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where + type HandleMonad (TlsHandle h g) = TlsM h g + type DebugLevel (TlsHandle h g) = DebugLevel h + hlPut (TlsHandleC t) = hlPut t + hlGet = hlGetRn rehandshake . tlsHandleC + hlGetLine = hlGetLineRn rehandshake . tlsHandleC + hlGetContent = hlGetContentRn rehandshake . tlsHandleC + hlDebug (TlsHandleC t) = hlDebug t + hlClose (TlsHandleC t) = hlClose t + +moduleName :: String +moduleName = "Network.PeyoTLS.Client" + +names :: TlsHandle h g -> [String] +names = BASE.names . tlsHandleC + open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - TlsM h g (TlsHandleC h g) + TlsM h g (TlsHandle h g) open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do - setSettings (cscl, rcrt, ecrt, Just ca) - cr <- clientHello cscl - handshake rcrt ecrt ca cr - where - rcrt = first rsaKey <$> find (HB.isRsaKey . fst) crts - ecrt = first ecdsaKey <$> find (HB.isEcdsaKey . fst) crts + setSettingsC (cscl, crts, ca) + handshake crts ca =<< clientHello cscl -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleC h g -> TlsM h g () +renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do - (cscl, rcrt, ecrt, Just ca) <- getSettings - cr <- clientHello cscl - HB.debug "critical" ("CLIENT HASH AFTER CLIENTHELLO" :: String) - HB.debug "critical" =<< handshakeHash - ne <- flushAppData - when ne $ handshake rcrt ecrt ca cr + (cscl, crts, ca) <- getSettingsC + clientHello cscl >>= \cr -> + flushAppData >>= flip when (handshake crts ca cr) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () +rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do - (cscl, rcrt, ecrt, Just ca) <- getSettings - cr <- clientHello cscl - handshake rcrt ecrt ca cr - -handshake :: (ValidateHandle h, CPRG g) => - Maybe (RSA.PrivateKey, X509.CertificateChain) -> - Maybe (ECDSA.PrivateKey, X509.CertificateChain) -> - X509.CertificateStore -> BS.ByteString -> HandshakeM h g () -handshake rcrt ecrt ca cr = do - (sr, cs@(CipherSuite ke _)) <- serverHello - setCipherSuite cs - HB.debug "critical" ("CLIENT HASH AFTER SERVERHELLO" :: String) - HB.debug "critical" =<< handshakeHash - case ke of - RSA -> rsaHandshake cr sr crts ca - DHE_RSA -> dheHandshake dhType cr sr crts ca - ECDHE_RSA -> dheHandshake curveType cr sr crts ca - ECDHE_ECDSA -> dheHandshake curveType cr sr crts ca - _ -> error "not implemented" - where - dhType :: DH.Params; dhType = undefined - curveType :: ECC.Curve; curveType = undefined - crts = case (rcrt, ecrt) of - (Just (rsk, rcc), Just (esk, ecc)) -> [ - (RsaKey rsk, rcc), (EcdsaKey esk, ecc)] - (Just (rsk, rcc), _) -> [(RsaKey rsk, rcc)] - (_, Just (esk, ecc)) -> [(EcdsaKey esk, ecc)] - _ -> [] - -getRenegoInfo :: Maybe [Extension] -> Maybe BS.ByteString -getRenegoInfo Nothing = Nothing -getRenegoInfo (Just []) = Nothing -getRenegoInfo (Just (ERenegoInfo rn : _)) = Just rn -getRenegoInfo (Just (_ : es)) = getRenegoInfo $ Just es + (cscl, crts, ca) <- getSettingsC + handshake crts ca =<< clientHello cscl clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> HandshakeM h g BS.ByteString clientHello cscl = do cr <- randomByteString 32 - cf <- getClientFinished - writeHandshake . ClientHello (3, 3) cr (SessionId "") cscl - [CompMethodNull] $ Just [ERenegoInfo cf] + ((>>) <$> writeHandshake <*> debug "low") + . ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull] + . Just . (: []) =<< makeClientRenego return cr -serverHello :: (HandleLike h, CPRG g) => - HandshakeM h g (BS.ByteString, CipherSuite) +handshake :: (ValidateHandle h, CPRG g) => + [(CertSecretKey, X509.CertificateChain)] -> + X509.CertificateStore -> BS.ByteString -> HandshakeM h g () +handshake crts ca cr = do + (sr, ke) <- serverHello + ($ ca) . ($ crts) . ($ (cr, sr)) $ case ke of + RSA -> rsaHandshake + DHE_RSA -> dheHandshake (undefined :: DH.Params) + ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) + ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve) + _ -> \_ _ _ -> throwError ALFatal ADHsFailure $ + moduleName ++ ".handshake: not implemented" + +serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) serverHello = do - cf <- getClientFinished - sf <- getServerFinished - ServerHello _v sr _sid cs _cm e <- readHandshake - let Just rn = getRenegoInfo e - rn0 = cf `BS.append` sf - unless (rn == rn0) $ E.throwError "Network.PeyoTLS.Client.hello" - return (sr, cs) + ServerHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake + case v of + (3, 3) -> return () + _ -> throwError ALFatal ADProtocolVersion $ + moduleName ++ ".serverHello: only TLS 1.2" + case cm of + CompMethodNull -> return () + _ -> throwError ALFatal ADHsFailure $ + moduleName ++ ".serverHello: only compression method null" + case listToMaybe . mapMaybe eRenegoInfo $ fromMaybe [] e of + Just ri -> checkServerRenego ri + _ -> throwError ALFatal ADInsufficientSecurity $ + moduleName ++ ".serverHello: require secure renegotiation" + setCipherSuite cs + return (sr, ke) -rsaHandshake :: (ValidateHandle h, CPRG g) => - BS.ByteString -> BS.ByteString -> +rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> HandshakeM h g () -rsaHandshake cr sr crts ca = do +rsaHandshake rs crts ca = do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc - unless (null vr) $ E.throwError "TlsClient.rsaHandshake: validate failure" - let X509.PubKeyRSA pk = - X509.certPubKey . X509.signedObject $ X509.getSigned c + unless (null vr) . throwError ALFatal (validateAlert vr) $ + moduleName ++ ".rsaHandshake: validate failure" + pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of + X509.PubKeyRSA k -> return k + _ -> throwError ALFatal ADIllegalParameter $ + moduleName ++ ".rsaHandshake: require RSA public key" crt <- clientCertificate crts pms <- ("\x03\x03" `BS.append`) `liftM` randomByteString 46 - generateKeys Client (cr, sr) pms + generateKeys Client rs pms writeHandshake . Epms =<< encryptRsa pk pms finishHandshake crt -dheHandshake :: (ValidateHandle h, CPRG g, KeyExchangeClass ke, Show (Secret ke), - Show (Public ke)) => - ke -> BS.ByteString -> BS.ByteString -> +dheHandshake :: (ValidateHandle h, CPRG g, + KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => + ke -> (BS.ByteString, BS.ByteString) -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> HandshakeM h g () -dheHandshake t cr sr crts ca = do +dheHandshake t rs crts ca = do cc@(X509.CertificateChain cs) <- readHandshake - let c = last cs - case X509.certPubKey . X509.signedObject $ X509.getSigned c of - X509.PubKeyRSA pk -> succeedHandshake t pk cr sr cc crts ca - X509.PubKeyECDSA cv pnt -> - succeedHandshake t (ek cv pnt) cr sr cc crts ca - _ -> E.throwError "TlsClient.dheHandshake: not implemented" - where - ek cv pnt = ECDSA.PublicKey (ECC.getCurveByName cv) (point pnt) - point s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point - (either error id $ B.decode x) - (either error id $ B.decode y) - -succeedHandshake :: - (ValidateHandle h, CPRG g, Verify pk, KeyExchangeClass ke, Show (Secret ke), - Show (Public ke)) => - ke -> pk -> BS.ByteString -> BS.ByteString -> X509.CertificateChain -> - [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> - HandshakeM h g () -succeedHandshake t pk cr sr cc crts ca = do vr <- handshakeValidate ca cc - unless (null vr) $ - E.throwError "TlsClient.succeedHandshake: validate failure" - (ps, pv, ha, _sa, sn) <- serverKeyExchange + unless (null vr) . throwError ALFatal (validateAlert vr) $ + moduleName ++ ".succeed: validate failure" + case X509.certPubKey . X509.signedObject . X509.getSigned $ head cs of + X509.PubKeyRSA pk -> succeed t pk rs crts + X509.PubKeyECDSA cv pt -> succeed t (makeEcdsaPubKey cv pt) rs crts + _ -> throwError ALFatal ADHsFailure $ + moduleName ++ ".dheHandshake: not implemented" + +succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk, + KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) => + ke -> pk -> (BS.ByteString, BS.ByteString) -> + [(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g () +succeed t pk rs@(cr, sr) crts = do + (ps, pv, ha, sa, sn) <- serverKeyExchange let _ = ps `asTypeOf` t - unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) $ - E.throwError "TlsClient.succeedHandshake: verify failure" + unless (sa == svpAlgorithm pk) . throwError ALFatal ADHsFailure $ + pre ++ "sign algorithm unmatch" + unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . + throwError ALFatal ADDecryptError $ pre ++ "verify failure" crt <- clientCertificate crts sv <- withRandom $ generateSecret ps - generateKeys Client (cr, sr) $ calculateShared ps sv pv + generateKeys Client rs $ calculateShared ps sv pv writeHandshake . ClientKeyExchange . B.encode $ calculatePublic ps sv finishHandshake crt + where pre = moduleName ++ ".succeed: " class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g @@ -210,123 +189,45 @@ ServerKeyExDhe ps pv ha sa sn <- readHandshake return (ps, pv, ha, sa, sn) -class Verify pk where - verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool - -instance Verify RSA.PublicKey where - verify = rsaVerify - -rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool -rsaVerify ha pk sn m = let - (hs, oid0) = case ha of - Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26]) - Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1]) - _ -> error "not implemented" - (o, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail - . BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of - Right [ASN1.Start ASN1.Sequence, - ASN1.Start ASN1.Sequence, oid_, ASN1.Null, ASN1.End ASN1.Sequence, - ASN1.OctetString o_, ASN1.End ASN1.Sequence ] -> (o_, oid_) - e -> error $ show e in - oid == oid0 && o == hs m - -instance Verify ECDSA.PublicKey where - verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode - verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode - verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented" - clientCertificate :: (HandleLike h, CPRG g) => [(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain)) clientCertificate crts = do - shd <- readHandshake - case shd of - Left (CertificateRequest ca hsa dn) -> do - ServerHelloDone <- readHandshake - case find (isMatchedCert ca hsa dn) crts of - Just (sk, rcc) -> do - writeHandshake rcc - return $ Just (sk, rcc) - _ -> E.throwError . E.strMsg $ - "TlsClient.clientCertificate: " ++ - "no certificate" - Right ServerHelloDone -> return Nothing - _ -> E.throwError "TlsClient.clientCertificate" + h <- readHandshake + (\p -> either p (\SHDone -> return Nothing) h) $ \(CertReq cct a dn) -> do + SHDone <- readHandshake + case find (isMatchedCert cct a dn) crts of + Just c -> + (>>) <$> writeHandshake . snd <*> return . Just $ c + _ -> throwError ALFatal ADUnknownCa $ moduleName ++ + ".clientCertificate: no certificate" isMatchedCert :: [ClientCertificateType] -> [(HashAlg, SignAlg)] -> [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd where - csk (RsaKey _) = CTRsaSign `elem` ct || Rsa `elem` map snd hsa - csk (EcdsaKey _) = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa - ccrt (X509.CertificateChain cs@(c : _)) = - cpk pk && not (null $ intersect dn issr) - where - obj = X509.signedObject . X509.getSigned - pk = X509.certPubKey $ obj c - issr = map (X509.certIssuerDN . obj) cs - ccrt _ = error "TlsClient.certIsOk: empty certificate chain" - cpk X509.PubKeyRSA {} = CTRsaSign `elem` ct || Rsa `elem` map snd hsa - cpk X509.PubKeyECDSA {} = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa - cpk _ = False + obj = X509.signedObject . X509.getSigned + rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa + ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa + csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa + ccrt (X509.CertificateChain cs) = + cpk (X509.certPubKey . obj $ head cs) && + not (null . intersect dn $ map (X509.certIssuerDN . obj) cs) + cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False finishHandshake :: (HandleLike h, CPRG g) => Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g () finishHandshake crt = do hs <- handshakeHash - case crt of - Just (RsaKey sk, X509.CertificateChain (c : _)) -> - writeHandshake $ digitallySigned sk (pubKey sk c) hs - Just (EcdsaKey sk, X509.CertificateChain (c : _)) -> - writeHandshake $ digitallySigned sk (pubKey sk c) hs + case fst <$> crt of + Just (RsaKey sk) -> writeHandshake $ + DigitallySigned (csAlgorithm sk) $ csSign sk hs + Just (EcdsaKey sk) -> writeHandshake $ + DigitallySigned (csAlgorithm sk) $ csSign sk hs _ -> return () putChangeCipherSpec >> flushCipherSuite Write - fc <- finishedHash Client - writeHandshake fc + writeHandshake =<< finishedHash Client getChangeCipherSpec >> flushCipherSuite Read - fs <- finishedHash Server - (fs ==) `liftM` readHandshake >>= flip unless - (E.throwError "TlsClient.finishHandshake: finished hash failure") - where - digitallySigned sk pk hs = DigitallySigned (algorithm sk) $ sign sk pk hs - -class SecretKey sk where - type PubKey sk - pubKey :: sk -> X509.SignedCertificate -> PubKey sk - sign :: sk -> PubKey sk -> BS.ByteString -> BS.ByteString - algorithm :: sk -> (HashAlg, SignAlg) - -instance SecretKey RSA.PrivateKey where - type PubKey RSA.PrivateKey = RSA.PublicKey - pubKey _ c = case X509.certPubKey . X509.signedObject $ X509.getSigned c of - X509.PubKeyRSA pk -> pk - _ -> error "TlsClient: RSA.PrivateKey.pubKey" - sign sk pk m = let pd = rsaPadding pk m in RSA.dp Nothing sk pd - algorithm _ = (Sha256, Rsa) - -instance SecretKey ECDSA.PrivateKey where - type PubKey ECDSA.PrivateKey = () - pubKey _ _ = () - sign sk _ m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m - where - q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk - x = ECDSA.private_d sk - enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [ - ASN1.Start ASN1.Sequence, - ASN1.IntVal r, ASN1.IntVal s, - ASN1.End ASN1.Sequence] - algorithm _ = (Sha256, Ecdsa) - -newtype TlsHandleC h g = TlsHandleC { tlsHandleC :: TlsHandle h g } - -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleC h g) where - type HandleMonad (TlsHandleC h g) = TlsM h g - type DebugLevel (TlsHandleC h g) = DebugLevel h - hlPut (TlsHandleC t) = hlPut t - hlGet = hlGetRn rehandshake . tlsHandleC - hlGetLine = hlGetLineRn rehandshake . tlsHandleC - hlGetContent = hlGetContentRn rehandshake . tlsHandleC - hlDebug (TlsHandleC t) = hlDebug t - hlClose (TlsHandleC t) = hlClose t - -type PeyotlsHandleC = TlsHandleC Handle SystemRNG + (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless + (throwError ALFatal ADDecryptError $ + moduleName ++ ".finishHandshake: finished hash failure") diff --git a/src/Network/PeyoTLS/Handle.hs b/src/Network/PeyoTLS/Handle.hs --- a/src/Network/PeyoTLS/Handle.hs +++ b/src/Network/PeyoTLS/Handle.hs @@ -3,7 +3,7 @@ module Network.PeyoTLS.Handle ( TlsM, Alert(..), AlertLevel(..), AlertDesc(..), run, withRandom, randomByteString, - TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..), + TlsHandle_(..), RW(..), Side(..), ContentType(..), CipherSuite(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, @@ -13,8 +13,10 @@ getClientFinishedT, setClientFinishedT, getServerFinishedT, setServerFinishedT, + Settings, + getSettingsT, setSettingsT, getInitSetT, setInitSetT, - InitialSettings, + SettingsS, resetSequenceNumber, tlsGet_, @@ -54,20 +56,21 @@ PartnerId, newPartnerId, Keys(..), getClientFinished, setClientFinished, getServerFinished, setServerFinished, - InitialSettings, + Settings, getSettings, setSettings, + SettingsS, getInitSet, setInitSet, CertSecretKey(..), ) import qualified Network.PeyoTLS.Crypto as CT ( makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) -data TlsHandle h g = TlsHandle { +data TlsHandle_ h g = TlsHandle_ { clientId :: PartnerId, tlsHandle :: h, names :: [String] } deriving Show -type HandleHash h g = (TlsHandle h g, SHA256.Ctx) +type HandleHash h g = (TlsHandle_ h g, SHA256.Ctx) data Side = Server | Client deriving (Show, Eq) @@ -78,15 +81,15 @@ Right r -> return r Left a -> error $ show a -newHandle :: HandleLike h => h -> TlsM h g (TlsHandle h g) +newHandle :: HandleLike h => h -> TlsM h g (TlsHandle_ h g) newHandle h = do s <- get let (i, s') = newPartnerId s put s' - return TlsHandle { + return TlsHandle_ { clientId = i, tlsHandle = h, names = [] } -getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType +getContentType :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ContentType getContentType t = do ct <- fst `liftM` getBuf (clientId t) (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do @@ -95,7 +98,7 @@ return ct' flushAppData :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (BS.ByteString, Bool) + TlsHandle_ h g -> TlsM h g (BS.ByteString, Bool) flushAppData t = do ct <- getContentType t case ct of @@ -123,13 +126,13 @@ | otherwise -> updateHash hh bs _ -> return hh -tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> +tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) -> HandleHash h g -> Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n buffered :: (HandleLike h, CPRG g) => - TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) + TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered t n = do (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b if rl <= 0 @@ -144,8 +147,8 @@ setBuf (clientId t) (ct', b') second (b `BS.append`) `liftM` buffered t rl -buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> - TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) +buffered_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) -> + TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered_ rn t n = do ct0 <- getContentType t case ct0 of @@ -161,7 +164,7 @@ second (b `BS.append`) `liftM` buffered_ rn t rl splitRetBuf :: HandleLike h => - TlsHandle h g -> Int -> ContentType -> BS.ByteString -> + TlsHandle_ h g -> Int -> ContentType -> BS.ByteString -> TlsM h g (ContentType, BS.ByteString) splitRetBuf t n ct b = do let (ret, b') = BS.splitAt n b @@ -169,33 +172,33 @@ return (ct, ret) getWholeWithCt :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) + TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) getWholeWithCt t = do flush t ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1 [_vmj, _vmn] <- BS.unpack `liftM` read t 2 e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2 - when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null" + when (BS.null e) $ throwError "TlsHandle_.getWholeWithCt: e is null" p <- decrypt t ct e thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct thlDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p return (ct, p) -read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString +read :: (HandleLike h, CPRG g) => TlsHandle_ h g -> Int -> TlsM h g BS.ByteString read t n = do r <- thlGet (tlsHandle t) n unless (BS.length r == n) . throwError . strMsg $ - "TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n + "TlsHandle_.read: can't read " ++ show (BS.length r) ++ " " ++ show n return r decrypt :: HandleLike h => - TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString + TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt t ct e = do ks <- getKeys $ clientId t decrypt_ t ks ct e -decrypt_ :: HandleLike h => TlsHandle h g -> +decrypt_ :: HandleLike h => TlsHandle_ h g -> Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e decrypt_ t ks ct e = do @@ -206,7 +209,7 @@ hs <- case be of AES_128_CBC_SHA -> return CT.hashSha1 AES_128_CBC_SHA256 -> return CT.hashSha256 - _ -> throwError "TlsHandle.decrypt: not implement bulk encryption" + _ -> throwError "TlsHandle_.decrypt: not implement bulk encryption" either (throwError . strMsg) return $ CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e @@ -223,7 +226,7 @@ (CTHandshake, True) -> updateHash hh p _ -> return hh -flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () +flush :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g () flush t = do (bct, bp) <- getWBuf $ clientId t setWBuf (clientId t) (CTNull, "") @@ -233,12 +236,12 @@ B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] encrypt :: (HandleLike h, CPRG g) => - TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString + TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt t ct p = do ks <- getKeys $ clientId t encrypt_ t ks ct p -encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g -> +encrypt_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p encrypt_ t ks ct p = do @@ -249,14 +252,14 @@ hs <- case be of AES_128_CBC_SHA -> return CT.hashSha1 AES_128_CBC_SHA256 -> return CT.hashSha256 - _ -> throwError "TlsHandle.encrypt: not implemented bulk encryption" + _ -> throwError "TlsHandle_.encrypt: not implemented bulk encryption" withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p updateHash :: HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g) updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs) -updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64 +updateSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g Word64 updateSequenceNumber t rw = do ks <- getKeys $ clientId t (sn, cs) <- case rw of @@ -269,12 +272,12 @@ Write -> succWriteSn $ clientId t return sn -resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g () +resetSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g () resetSequenceNumber t rw = case rw of Read -> resetReadSn $ clientId t Write -> resetWriteSn $ clientId t -generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite -> +generateKeys :: HandleLike h => TlsHandle_ h g -> Side -> CipherSuite -> BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys generateKeys t p cs cr sr pms = do let CipherSuite _ be = cs @@ -304,7 +307,7 @@ Read -> flushCipherSuiteRead Write -> flushCipherSuiteWrite -debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g () +debugCipherSuite :: HandleLike h => TlsHandle_ h g -> String -> TlsM h g () debugCipherSuite t a = do k <- getKeys $ clientId t thlDebug (tlsHandle t) "high" . BSC.pack @@ -321,19 +324,19 @@ sha256 <- handshakeHash (t, ctx) return $ CT.finishedHash (partner == Client) ms sha256 -hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g () +hlPut_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> BS.ByteString -> TlsM h g () hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined) hlDebug_ :: HandleLike h => - TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g () + TlsHandle_ h g -> DebugLevel h -> BS.ByteString -> TlsM h g () hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l -hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g () +hlClose_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g () hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> flush t >> thlClose (tlsHandle t) tGetLine :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) + TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetLine t = do (bct, bp) <- getBuf $ clientId t case splitLine bp of @@ -342,8 +345,8 @@ setBuf (clientId t) cp second (bp `BS.append`) `liftM` tGetLine t -tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) -> - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) +tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) -> + TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetLine_ rn t = do ct <- getContentType t case ct of @@ -372,30 +375,36 @@ _ -> Nothing tGetContent :: (HandleLike h, CPRG g) => - TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) + TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetContent t = do bcp@(_, bp) <- getBuf $ clientId t if BS.null bp then getWholeWithCt t else setBuf (clientId t) (CTNull, BS.empty) >> return bcp getClientFinishedT, getServerFinishedT :: - HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString + HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString getClientFinishedT = getClientFinished . clientId getServerFinishedT = getServerFinished . clientId setClientFinishedT, setServerFinishedT :: - HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () + HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g () setClientFinishedT = setClientFinished . clientId setServerFinishedT = setServerFinished . clientId -getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings +getSettingsT :: HandleLike h => TlsHandle_ h g -> TlsM h g Settings +getSettingsT = getSettings . clientId + +getInitSetT :: HandleLike h => TlsHandle_ h g -> TlsM h g SettingsS getInitSetT = getInitSet . clientId -setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g () +setSettingsT :: HandleLike h => TlsHandle_ h g -> Settings -> TlsM h g () +setSettingsT = setSettings . clientId + +setInitSetT :: HandleLike h => TlsHandle_ h g -> SettingsS -> TlsM h g () setInitSetT = setInitSet . clientId -getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString +getAdBufT :: HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString getAdBufT = getAdBuf . clientId -setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g () +setAdBufT :: HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g () setAdBufT = setAdBuf . clientId diff --git a/src/Network/PeyoTLS/Monad.hs b/src/Network/PeyoTLS/Monad.hs --- a/src/Network/PeyoTLS/Monad.hs +++ b/src/Network/PeyoTLS/Monad.hs @@ -10,7 +10,8 @@ resetReadSn, resetWriteSn, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, - getInitSet, setInitSet, S.InitialSettings, + getSettings, setSettings, + getInitSet, setInitSet, S.SettingsS, S.Settings, S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), S.ContentType(..), S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..), @@ -41,11 +42,12 @@ getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, + getSettings, setSettings, getInitSet, setInitSet, getClientFinished, setClientFinished, getServerFinished, setServerFinished, - InitialSettings, + SettingsS, Settings, CertSecretKey(..), ) @@ -90,11 +92,17 @@ getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys getKeys = gets . S.getKeys -getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.InitialSettings +getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS getInitSet = gets . S.getInitSet -setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g () +getSettings :: HandleLike h => S.PartnerId -> TlsM h g S.Settings +getSettings = gets . S.getSettings + +setInitSet :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g () setInitSet = (modify .) . S.setInitSet + +setSettings :: HandleLike h => S.PartnerId -> S.Settings -> TlsM h g () +setSettings = (modify .) . S.setSettings getClientFinished, getServerFinished :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString diff --git a/src/Network/PeyoTLS/ReadFile.hs b/src/Network/PeyoTLS/ReadFile.hs --- a/src/Network/PeyoTLS/ReadFile.hs +++ b/src/Network/PeyoTLS/ReadFile.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections #-} +{-# LANGUAGE TupleSections #-} module Network.PeyoTLS.ReadFile ( CertSecretKey, readKey, readCertificateChain, readCertificateStore) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow ((***)) -import Control.Monad (unless) +import Control.Monad (unless, forM) import qualified Data.ByteString as BS import qualified Data.ASN1.Types as ASN1 @@ -17,30 +17,26 @@ import qualified Data.X509.File as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B -import Codec.Bytable.BigEndian () import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.Types.PubKey.ECDSA as ECDSA -import Network.PeyoTLS.CertSecretKey +import Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) readKey :: FilePath -> IO CertSecretKey -readKey fp = do - rk <- readRsaKey fp - maybe (readEcdsaKey fp) return rk +readKey fp = maybe (readEcdsaKey fp) return =<< readRsaKey fp readRsaKey :: FilePath -> IO (Maybe CertSecretKey) -readRsaKey fp = do - ks <- X509.readKeyFile fp - case ks of - [X509.PrivKeyRSA sk] -> return . Just $ RsaKey sk - _ -> return Nothing -- error "ReadFile.readRsaKey: not single RSA key" +readRsaKey fp = X509.readKeyFile fp >>= \ks -> case ks of + [X509.PrivKeyRSA sk] -> return . Just $ RsaKey sk + _ -> return Nothing readEcdsaKey :: FilePath -> IO CertSecretKey readEcdsaKey = (EcdsaKey . either error id . decodeEcdsaKey <$>) . BS.readFile -readCertificateChain :: FilePath -> IO X509.CertificateChain -readCertificateChain = (X509.CertificateChain <$>) . X509.readSignedObject +readCertificateChain :: [FilePath] -> IO X509.CertificateChain +readCertificateChain fps = + X509.CertificateChain . concat <$> forM fps X509.readSignedObject readCertificateStore :: [FilePath] -> IO X509.CertificateStore readCertificateStore = @@ -51,9 +47,11 @@ pms <- either (Left . show) return $ PEM.pemParseBS bs pm <- fromSinglePem pms pmc <- case pm of - PEM.PEM { PEM.pemName = "EC PRIVATE KEY", PEM.pemHeader = [], + PEM.PEM { + PEM.pemName = "EC PRIVATE KEY", + PEM.pemHeader = [], PEM.pemContent = c } -> return c - _ -> Left $ msgp ++ "bad PEM structure" + _ -> Left $ pre ++ "bad PEM structure" asn <- either (Left . show) return $ ASN1.decodeASN1' ASN1.DER pmc (sk, oid, pk) <- case asn of [ASN1.Start ASN1.Sequence, @@ -65,20 +63,20 @@ ASN1.BitString (ASN1.BitArray _pl p), ASN1.End (ASN1.Container ASN1.Context 1), ASN1.End ASN1.Sequence] -> (, o, p) <$> B.decode s - _ -> Left $ msgp ++ "bad ASN.1 structure" - unless (oid == oidSecp256r1) . Left $ msgp ++ "not implemented curve" + _ -> Left $ pre ++ "bad ASN.1 structure" + unless (oid == oidSecp256r1) . Left $ pre ++ "not implemented curve" tpk <- case BS.uncons pk of Just (4, t) -> return t - _ -> Left $ msgp ++ "not implemented point format" + _ -> Left $ pre ++ "not implemented point format" (x, y) <- (\(ex, ey) -> (,) <$> ex <*> ey) . (B.decode *** B.decode) $ BS.splitAt 32 tpk unless (ECC.Point x y == ECC.pointMul secp256r1 sk g) . - Left $ msgp ++ "the public key not match" + Left $ pre ++ "the public key not match" return $ ECDSA.PrivateKey secp256r1 sk where - msgp = "ReadFile.decodeEcdsaKey: " + pre = "ReadFile.decodeEcdsaKey: " fromSinglePem [x] = return x - fromSinglePem _ = Left $ msgp ++ "not single PEM" + fromSinglePem _ = Left $ pre ++ "not single PEM" g = ECC.ecc_g $ ECC.common_curve secp256r1 secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 oidSecp256r1 = ASN1.OID [1, 2, 840, 10045, 3, 1, 7] diff --git a/src/Network/PeyoTLS/Run.hs b/src/Network/PeyoTLS/Run.hs --- a/src/Network/PeyoTLS/Run.hs +++ b/src/Network/PeyoTLS/Run.hs @@ -4,7 +4,7 @@ TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, ValidateHandle(..), handshakeValidate, - TH.TlsHandle(..), TH.ContentType(..), + TH.TlsHandle_(..), TH.ContentType(..), getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, tlsGetContentType, tlsGet, tlsPut, tlsPutNH, generateKeys, encryptRsa, decryptRsa, rsaPadding, @@ -18,7 +18,8 @@ resetSequenceNumber, - getSettings, setSettings, + getSettings, setSettings, TH.SettingsS, + getSettingsC, setSettingsC, TH.Settings, flushAppData_, getAdBuf, setAdBuf, @@ -54,7 +55,7 @@ import qualified Network.PeyoTLS.Handle as TH ( TlsM, Alert(..), AlertLevel(..), AlertDesc(..), run, withRandom, randomByteString, - TlsHandle(..), ContentType(..), + TlsHandle_(..), ContentType(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, @@ -65,7 +66,8 @@ resetSequenceNumber, - getInitSetT, setInitSetT, InitialSettings, + getSettingsT, setSettingsT, Settings, + getInitSetT, setInitSetT, SettingsS, tlsGet_, flushAppData, getAdBufT, @@ -78,17 +80,17 @@ resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw tlsGet_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g -> TH.TlsM h g ()) -> - (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) + (TH.TlsHandle_ h g -> TH.TlsM h g ()) -> + (TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx)) tlsGet_ = TH.tlsGet_ tlsGet__ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx)) + (TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx)) tlsGet__ = TH.tlsGet True tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g -> TH.TlsM h g ()) -> - TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) + (TH.TlsHandle_ h g -> TH.TlsM h g ()) -> + TH.TlsHandle_ h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) tGetLine_ = TH.tGetLine_ flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool) @@ -101,22 +103,22 @@ _ -> TH.tGetContent t tlsPut_ :: (HandleLike h, CPRG g) => - (TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx) + (TH.TlsHandle_ h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle_ h g, SHA256.Ctx) tlsPut_ = TH.tlsPut True throwError :: HandleLike h => TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a throwError al ad m = E.throwError $ TH.Alert al ad m -type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g) +type HandshakeM h g = StateT (TH.TlsHandle_ h g, SHA256.Ctx) (TH.TlsM h g) execHandshakeM :: HandleLike h => - h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g) + h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle_ h g) execHandshakeM h = liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT rerunHandshakeM :: - HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a + HandleLike h => TH.TlsHandle_ h g -> HandshakeM h g a -> TH.TlsM h g a rerunHandshakeM t hm = evalStateT hm (t, SHA256.init) withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a @@ -154,7 +156,7 @@ X509.CertificateStore -> X509.CertificateChain -> HandshakeM h g [X509.FailedReason] handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do - modify . first $ const t { TH.names = certNames . X509.getCertificate $ last c } + modify . first $ const t { TH.names = certNames . X509.getCertificate $ head c } lift . lift . lift $ validate (TH.tlsHandle t) cs cc setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g () @@ -224,17 +226,23 @@ setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf -getSettings :: HandleLike h => HandshakeM h g TH.InitialSettings +getSettings :: HandleLike h => HandshakeM h g TH.SettingsS getSettings = gets fst >>= lift . TH.getInitSetT -setSettings :: HandleLike h => TH.InitialSettings -> HandshakeM h g () +getSettingsC :: HandleLike h => HandshakeM h g TH.Settings +getSettingsC = gets fst >>= lift . TH.getSettingsT + +setSettings :: HandleLike h => TH.SettingsS -> HandshakeM h g () setSettings is = gets fst >>= lift . flip TH.setInitSetT is -getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString +setSettingsC :: HandleLike h => TH.Settings -> HandshakeM h g () +setSettingsC is = gets fst >>= lift . flip TH.setSettingsT is + +getAdBuf :: HandleLike h => TH.TlsHandle_ h g -> TH.TlsM h g BS.ByteString getAdBuf = TH.getAdBufT setAdBuf :: HandleLike h => - TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g () + TH.TlsHandle_ h g -> BS.ByteString -> TH.TlsM h g () setAdBuf = TH.setAdBufT getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString diff --git a/src/Network/PeyoTLS/Server.hs b/src/Network/PeyoTLS/Server.hs --- a/src/Network/PeyoTLS/Server.hs +++ b/src/Network/PeyoTLS/Server.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports, TupleSections #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Server ( - PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS, run, open, renegotiate, names, - CipherSuite(..), KeyEx(..), BulkEnc(..), ValidateHandle(..), CertSecretKey - ) where + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names, + CipherSuite(..), KeyEx(..), BulkEnc(..), + ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first) @@ -18,52 +18,44 @@ import qualified Data.ByteString as BS import qualified Data.X509 as X509 -import qualified Data.X509.Validation as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.Prim as RSA -import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Crypto.Types.PubKey.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.Base as HB (names) +import qualified Network.PeyoTLS.Base as BASE (names) import Network.PeyoTLS.Base ( PeyotlsM, TlsM, run, + SettingsS, getSettings, setSettings, + hlGetRn, hlGetLineRn, hlGetContentRn, HandshakeM, execHandshakeM, rerunHandshakeM, - throwError, debug, debugCipherSuite, - withRandom, randomByteString, - ValidateHandle(..), handshakeValidate, - TlsHandle, CertSecretKey(..), isRsaKey, isEcdsaKey, - readHandshake, getChangeCipherSpec, - writeHandshake, putChangeCipherSpec, - writeHandshakeNH, - AlertLevel(..), AlertDesc(..), - ClientHello(..), ServerHello(..), SessionId(..), Extension(..), + withRandom, randomByteString, flushAppData, + AlertLevel(..), AlertDesc(..), throwError, debugCipherSuite, + ValidateHandle(..), handshakeValidate, validateAlert, + TlsHandle_, CertSecretKey(..), isRsaKey, isEcdsaKey, + readHandshake, writeHandshake, writeHandshakeNH, + getChangeCipherSpec, putChangeCipherSpec, + Handshake(HHelloReq), + ClientHello(..), ServerHello(..), SessionId(..), Extension(..), eRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), getCipherSuite, setCipherSuite, - getClientFinished, getServerFinished, - ServerKeyExchange(..), - certificateRequest, ClientCertificateType(..), SecretKey(..), + checkClientRenego, makeServerRenego, + ServerKeyExchange(..), SecretKey(..), + certificateRequest, ClientCertificateType(..), ServerHelloDone(..), - ClientKeyExchange(..), Epms(..), - generateKeys, decryptRsa, rsaPadding, - DigitallySigned(..), handshakeHash, + ClientKeyExchange(..), Epms(..), generateKeys, decryptRsa, + DigitallySigned(..), ClSignPublicKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash, - DhParam(..), dh3072Modp, secp256r1, - - Handshake(HHelloReq), eRenegoInfo, getSettings, setSettings, flushAppData, - hlGetRn, hlGetLineRn, hlGetContentRn ) + DhParam(..), makeEcdsaPubKey, dh3072Modp, secp256r1 ) -type PeyotlsHandleS = TlsHandleS Handle SystemRNG +type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g } deriving Show +newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandle_ h g } deriving Show -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where - type HandleMonad (TlsHandleS h g) = TlsM h g - type DebugLevel (TlsHandleS h g) = DebugLevel h +instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where + type HandleMonad (TlsHandle h g) = TlsM h g + type DebugLevel (TlsHandle h g) = DebugLevel h hlPut (TlsHandleS t) = hlPut t hlGet = hlGetRn rehandshake . tlsHandleS hlGetLine = hlGetLineRn rehandshake . tlsHandleS @@ -72,21 +64,19 @@ hlClose (TlsHandleS t) = hlClose t type Version = (Word8, Word8) -type Settings = ( - [CipherSuite], - Maybe (RSA.PrivateKey, X509.CertificateChain), - Maybe (ECDSA.PrivateKey, X509.CertificateChain), - Maybe X509.CertificateStore ) version :: Version version = (3, 3) -names :: TlsHandleS h g -> [String] -names = HB.names . tlsHandleS +moduleName :: String +moduleName = "Network.PeyoTLS.Server" -open :: (ValidateHandle h, CPRG g) => h -> - [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> - Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g) +names :: TlsHandle h g -> [String] +names = BASE.names . tlsHandleS + +open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> + [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> + TlsM h g (TlsHandle h g) open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $ ((>>) <$> setSettings <*> handshake) (cssv', first rsaKey <$> find (isRsaKey . fst) crts, @@ -101,215 +91,143 @@ iscs EMPTY_RENEGOTIATION_INFO = False iscs _ = True -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g () +renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >> flushAppData >>= flip when (handshake =<< getSettings) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () +rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ handshake =<< getSettings -handshake :: (ValidateHandle h, CPRG g) => Settings -> HandshakeM h g () +handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () handshake (cssv, rcrt, ecrt, mcs) = do - (ke, be, cr, cv, rn) <- clientHello cssv - sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) rn + (ke, be, cr, cv) <- clientHello cssv + sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) ha <- case be of AES_128_CBC_SHA -> return Sha1 AES_128_CBC_SHA256 -> return Sha256 _ -> throwError ALFatal ADInternalError $ pre ++ "not implemented bulk encryption type" - mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, rcrt, ecrt) of - (RSA, Just (rsk, _), _) -> rsaKeyExchange rsk cv - (DHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha dh3072Modp rsk - (ECDHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha secp256r1 rsk - (ECDHE_ECDSA, _, Just (esk, _)) -> dhKeyExchange ha secp256r1 esk + mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of + (RSA, Just rsk, _) -> rsaKeyExchange rsk cv + (DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk + (ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk + (ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk _ -> \_ _ -> throwError ALFatal ADInternalError $ pre ++ "no implemented key exchange type or " ++ "no applicable certificate files" - maybe (return ()) certificateVerify mpk + flip (maybe $ return ()) mpk $ \pk -> case pk of + X509.PubKeyRSA rpk -> certVerify rpk + X509.PubKeyECDSA c xy -> certVerify $ makeEcdsaPubKey c xy + _ -> throwError ALFatal ADUnsupportedCertificate $ + pre ++ "not implement: " ++ show pk getChangeCipherSpec >> flushCipherSuite Read - (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> - unless ok . throwError ALFatal ADDecryptError $ - pre ++ "wrong finished hash" + (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok . + throwError ALFatal ADDecryptError $ pre ++ "wrong finished hash" putChangeCipherSpec >> flushCipherSuite Write writeHandshake =<< finishedHash Server - where pre = "Network.PeyoTLS.Server.handshake: " + where pre = moduleName ++ ".handshake: " clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> - HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version, Bool) + HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do ClientHello cv cr _sid cscl cms me <- readHandshake - checkRenegotiation cscl me + checkRenegoInfo cscl me unless (cv >= version) . throwError ALFatal ADProtocolVersion $ - pre ++ "client version should 3.3 or more" + pre ++ "only implement TLS 1.2" unless (CompMethodNull `elem` cms) . throwError ALFatal ADDecodeError $ pre ++ "compression method NULL must be supported" (ke, be) <- case find (`elem` cscl) cssv of Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b) - _ -> throwError ALFatal ADHandshakeFailure $ - pre ++ "no acceptable set of security parameters" - return (ke, be, cr, cv, True) - where pre = "Network.PeyoTLS.Server.clientHello: " + _ -> throwError ALFatal ADHsFailure $ + pre ++ "no acceptable set of security parameters: \n\t" ++ + "cscl: " ++ show cscl ++ "\n\t" ++ + "cssv: " ++ show cssv ++ "\n" + return (ke, be, cr, cv) + where pre = moduleName ++ ".clientHello: " -checkRenegotiation :: +checkRenegoInfo :: HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () -checkRenegotiation cscl me = do - case mcf of - Just cf -> (cf ==) `liftM` getClientFinished >>= \ok -> unless ok . - throwError ALFatal ADHandshakeFailure $ - pre ++ "bad renegotiation" - _ -> throwError ALFatal ADInsufficientSecurity $ - pre ++ "require secure renegotiation" - where - pre = "Network.PeyoTLS.Server.checkRenegotiation: " - mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of +checkRenegoInfo cscl me = (\n -> maybe n checkClientRenego mcf) . throwError + ALFatal ADInsufficientSecurity $ + moduleName ++ ".checkRenego: require secure renegotiation" + where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of (True, _) -> Just "" (_, Just e) -> listToMaybe $ mapMaybe eRenegoInfo e (_, _) -> Nothing serverHello :: (HandleLike h, CPRG g) => - Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> Bool -> + Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> HandshakeM h g BS.ByteString -serverHello rcc ecc rn = do - cs@(CipherSuite ke _) <- getCipherSuite +serverHello rcc ecc = do + cs <- getCipherSuite + ke <- case cs of + CipherSuite k _ -> return k + _ -> throwError ALFatal ADInternalError $ + moduleName ++ ".serverHello: never occur" sr <- randomByteString 32 - cf <- getClientFinished - sf <- getServerFinished - writeHandshake . ServerHello - version sr (SessionId "") cs CompMethodNull $ if rn - then Just [ERenegoInfo $ cf `BS.append` sf] - else Nothing - debug "critical" ("SERVER HASH AFTER SERVERHELLO" :: String) - debug "critical" =<< handshakeHash - writeHandshake $ case (ke, rcc, ecc) of - (ECDHE_ECDSA, _, Just c) -> c - (_, Just c, _) -> c - _ -> error "serverHello" + writeHandshake + . ServerHello version sr (SessionId "") cs CompMethodNull + . Just . (: []) =<< makeServerRenego + writeHandshake =<< case (ke, rcc, ecc) of + (ECDHE_ECDSA, _, Just c) -> return c + (_, Just c, _) -> return c + _ -> throwError ALFatal ADInternalError $ + moduleName ++ ".serverHello: cert files not match" return sr - {- -serverHello _ _ _ _ = throwError ALFatal ADInternalError - "Network.PeyoTLS.Server.serverHello: never occur" - -} rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) -rsaKeyExchange rsk cv rs mcs = return const - `ap` requestAndCertificate mcs - `ap` rsaClientKeyExchange rsk cv rs +rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do + Epms epms <- readHandshake + generateKeys Server rs =<< mkpms epms `catchError` const + ((BS.cons vj . BS.cons vn) `liftM` randomByteString 46) + where mkpms epms = do + pms <- decryptRsa sk epms + unless (BS.length pms == 48) $ throwError ALFatal ADHsFailure "" + let [pvj, pvn] = BS.unpack $ BS.take 2 pms + unless (pvj == vj && pvn == vn) $ throwError ALFatal ADHsFailure "" + return pms -dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk, Show (Secret dp), - Show (Public dp), +dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk, DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => - HashAlg -> dp -> sk -> - (BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> - HandshakeM h g (Maybe X509.PubKey) -dhKeyExchange ha dp ssk rs mcs = do + HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) -> + Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) +dhKeyExchange ha dp sk rs@(cr, sr) mcs = do sv <- withRandom $ generateSecret dp - serverKeyExchange ha dp sv ssk rs - return const - `ap` requestAndCertificate mcs - `ap` dhClientKeyExchange dp sv rs - -serverKeyExchange :: (HandleLike h, CPRG g, SecretKey sk, - DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => - HashAlg -> dp -> Secret dp -> sk -> - (BS.ByteString, BS.ByteString) -> HandshakeM h g () -serverKeyExchange ha dp sv ssk (cr, sr) = do - bl <- withRandom $ generateBlinder ssk + bl <- withRandom $ generateBlinder sk + let pv = B.encode $ calculatePublic dp sv writeHandshake - . ServerKeyEx edp pv ha (signatureAlgorithm ssk) - . sign ha bl ssk $ BS.concat [cr, sr, edp, pv] - where - edp = B.encode dp - pv = B.encode $ calculatePublic dp sv + . ServerKeyEx (B.encode dp) pv ha (signatureAlgorithm sk) + . sign ha bl sk $ BS.concat [cr, sr, B.encode dp, pv] + const `liftM` reqAndCert mcs `ap` do + ClientKeyExchange cke <- readHandshake + generateKeys Server rs . calculateShared dp sv =<< + either (throwError ALFatal ADInternalError . + (moduleName ++) . (".dhKeyExchange: " ++)) + return (B.decode cke) -requestAndCertificate :: (ValidateHandle h, CPRG g) => +reqAndCert :: (ValidateHandle h, CPRG g) => Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) -requestAndCertificate mcs = do +reqAndCert mcs = do flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] - writeHandshake ServerHelloDone - debug "high" ("SERVER HASH AFTER SERVERHELLODONE" :: String) - debug "high" =<< handshakeHash - maybe (return Nothing) (liftM Just . clientCertificate) mcs - -clientCertificate :: (ValidateHandle h, CPRG g) => - X509.CertificateStore -> HandshakeM h g X509.PubKey -clientCertificate cs = do - cc@(X509.CertificateChain (c : _)) <- readHandshake - chk cc - return . X509.certPubKey $ X509.getCertificate c - where - chk cc = do - rs <- handshakeValidate cs cc - unless (null rs) . throwError ALFatal (selectAlert rs) $ - "TlsServer.clientCertificate: " ++ show rs - selectAlert rs - | X509.UnknownCA `elem` rs = ADUnknownCa - | X509.Expired `elem` rs = ADCertificateExpired - | X509.InFuture `elem` rs = ADCertificateExpired - | otherwise = ADCertificateUnknown - -rsaClientKeyExchange :: (HandleLike h, CPRG g) => RSA.PrivateKey -> - Version -> (BS.ByteString, BS.ByteString) -> HandshakeM h g () -rsaClientKeyExchange sk (cvj, cvn) rs = do - Epms epms <- readHandshake - debug "low" ("EPMS" :: String) - debug "low" epms - generateKeys Server rs =<< mkpms epms `catchError` const - ((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46) - where - mkpms epms = do - pms <- decryptRsa sk epms - unless (BS.length pms == 48) $ - throwError ALFatal ADHandshakeFailure "" - case BS.unpack $ BS.take 2 pms of - [pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $ - throwError ALFatal ADHandshakeFailure "" - _ -> error $ "Network.PeyoTLS.Server." ++ - "rsaClientKeyExchange: never occur" - debug "low" ("PMS" :: String) - debug "low" pms - return pms - -dhClientKeyExchange :: (HandleLike h, CPRG g, DhParam dp, B.Bytable (Public dp), - Show (Public dp)) => - dp -> Secret dp -> (BS.ByteString, BS.ByteString) -> HandshakeM h g () -dhClientKeyExchange dp sv rs = do - ClientKeyExchange cke <- readHandshake - let Right pv = B.decode cke - generateKeys Server rs =<< case Right $ calculateShared dp sv pv of - Left em -> throwError ALFatal ADInternalError $ - "Network.PeyoTLS.Server.dhClientKeyExchange: " ++ em - Right sh -> return sh + writeHandshake SHDone + flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do + cc@(X509.CertificateChain (c : _)) <- readHandshake + vr <- handshakeValidate cs cc + unless (null vr) . throwError ALFatal (validateAlert vr) $ + moduleName ++ ".reqAndCert: " ++ show vr + return . X509.certPubKey $ X509.getCertificate c -certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g () -certificateVerify (X509.PubKeyRSA pk) = do - debugCipherSuite "RSA" - hs0 <- rsaPadding pk `liftM` handshakeHash - DigitallySigned a s <- readHandshake - case a of - (Sha256, Rsa) -> return () - _ -> throwError ALFatal ADDecodeError $ - "TlsServer.certificateVEerify: not implement: " ++ show a - unless (RSA.ep pk s == hs0) $ throwError ALFatal ADDecryptError - "TlsServer.certificateVerify: client auth failed " -certificateVerify (X509.PubKeyECDSA ECC.SEC_p256r1 xy) = do - debugCipherSuite "ECDSA" +certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g () +certVerify pk = do + debugCipherSuite . show $ cspAlgorithm pk hs0 <- handshakeHash DigitallySigned a s <- readHandshake case a of - (Sha256, Ecdsa) -> return () + (Sha256, sa) | sa == cspAlgorithm pk -> return () _ -> throwError ALFatal ADDecodeError $ - "TlsServer.certificateverify: not implement: " ++ show a - unless (ECDSA.verify id - (ECDSA.PublicKey secp256r1 $ pnt xy) - (either error id $ B.decode s) hs0) $ throwError - ALFatal ADDecryptError - "TlsServer.certificateverify: client auth failed" - where - pnt s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point - (either error id $ B.decode x) - (either error id $ B.decode y) -certificateVerify p = throwError ALFatal ADUnsupportedCertificate $ - "TlsServer.certificateVerify: not implement: " ++ show p + moduleName ++ ".certVerify: not implement: " ++ show a + unless (csVerify pk s hs0) . throwError ALFatal ADDecryptError $ + moduleName ++ ".certVerify: client auth failed " diff --git a/src/Network/PeyoTLS/State.hs b/src/Network/PeyoTLS/State.hs --- a/src/Network/PeyoTLS/State.hs +++ b/src/Network/PeyoTLS/State.hs @@ -10,16 +10,20 @@ getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, + getSettings, setSettings, getInitSet, setInitSet, getClientFinished, setClientFinished, getServerFinished, setServerFinished, - InitialSettings, + SettingsS, Settings, CertSecretKey(..), ) where +import Control.Applicative ((<$>)) +import Control.Arrow (first) import "monads-tf" Control.Monad.Error.Class (Error(strMsg)) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, maybeToList) +import Data.List (find) import Data.Word (Word8, Word64) import Data.String (IsString(..)) @@ -57,16 +61,39 @@ radBuffer = "", readSN = 0, writeSN = 0, rnClientFinished = "", rnServerFinished = "", - initialSettings = ([], Nothing, Nothing, Nothing) + initialSettings = ([], [], Nothing) } sos = states s -type InitialSettings = ( +type SettingsS = ( [CipherSuite], Maybe (RSA.PrivateKey, X509.CertificateChain), Maybe (ECDSA.PrivateKey, X509.CertificateChain), - Maybe X509.CertificateStore) + Maybe X509.CertificateStore ) +type Settings = ( + [CipherSuite], + [(CertSecretKey, X509.CertificateChain)], + Maybe X509.CertificateStore ) + +convertSettings :: Settings -> SettingsS +convertSettings (cs, crts, mcs) = (cs, + first rsaKey <$> find (isRsaKey . fst) crts, + first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) + +revertSettings :: SettingsS -> Settings +revertSettings (cs, rcrt, ecrt, mcs) = (cs, + maybeToList (first RsaKey <$> rcrt) ++ + maybeToList (first EcdsaKey <$> ecrt), mcs) + +isEcdsaKey :: CertSecretKey -> Bool +isEcdsaKey (EcdsaKey _) = True +isEcdsaKey _ = False + +isRsaKey :: CertSecretKey -> Bool +isRsaKey (RsaKey _) = True +isRsaKey _ = False + data StateOne g = StateOne { sKeys :: Keys, rBuffer :: (ContentType, BS.ByteString), @@ -76,7 +103,7 @@ writeSN :: Word64, rnClientFinished :: BS.ByteString, rnServerFinished :: BS.ByteString, - initialSettings :: InitialSettings + initialSettings :: Settings } getState :: PartnerId -> HandshakeState h g -> StateOne g @@ -136,7 +163,7 @@ data AlertDesc = ADCloseNotify | ADUnexpectedMessage | ADBadRecordMac - | ADRecordOverflow | ADDecompressionFailure | ADHandshakeFailure + | ADRecordOverflow | ADDecompressionFailure | ADHsFailure | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown | ADIllegalParameter | ADUnknownCa | ADDecodeError | ADDecryptError | ADProtocolVersion | ADInsufficientSecurity @@ -179,11 +206,19 @@ setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g) setKeys i = modifyState i . \k st -> st { sKeys = k } -getInitSet :: PartnerId -> HandshakeState h g -> InitialSettings -getInitSet i = initialSettings . fromJust' "getInitSet" . lookup i . states +getSettings :: PartnerId -> HandshakeState h g -> Settings +getSettings i = initialSettings . fromJust' "getSettings" . lookup i . states -setInitSet :: PartnerId -> InitialSettings -> Modify (HandshakeState h g) -setInitSet i = modifyState i . \is st -> st { initialSettings = is } +getInitSet :: PartnerId -> HandshakeState h g -> SettingsS +getInitSet i = convertSettings . + initialSettings . fromJust' "getInitSet" . lookup i . states + +setSettings :: PartnerId -> Settings -> Modify (HandshakeState h g) +setSettings i = modifyState i . \is st -> st { initialSettings = is } + +setInitSet :: PartnerId -> SettingsS -> Modify (HandshakeState h g) +setInitSet i = modifyState i . \is st -> st + { initialSettings = revertSettings is } getClientFinished, getServerFinished :: PartnerId -> HandshakeState h g -> BS.ByteString diff --git a/src/Network/PeyoTLS/Types.hs b/src/Network/PeyoTLS/Types.hs --- a/src/Network/PeyoTLS/Types.hs +++ b/src/Network/PeyoTLS/Types.hs @@ -7,7 +7,7 @@ CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertificateRequest(..), certificateRequest, ClientCertificateType(..), + CertReq(..), certificateRequest, ClientCertificateType(..), SignAlg(..), HashAlg(..), ServerHelloDone(..), ClientKeyExchange(..), Epms(..), DigitallySigned(..), Finished(..) ) where @@ -28,14 +28,14 @@ CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..) ) import Network.PeyoTLS.Certificate ( - CertificateRequest(..), certificateRequest, ClientCertificateType(..), + CertReq(..), certificateRequest, ClientCertificateType(..), ClientKeyExchange(..), DigitallySigned(..) ) data Handshake = HHelloReq | HClientHello ClientHello | HServerHello ServerHello | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString - | HCertificateReq CertificateRequest | HServerHelloDone + | HCertificateReq CertReq | HServerHelloDone | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange | HFinished BS.ByteString | HRaw Type BS.ByteString deriving Show @@ -163,13 +163,13 @@ hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString) hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2) -instance HandshakeItem CertificateRequest where +instance HandshakeItem CertReq where fromHandshake (HCertificateReq cr) = Just cr fromHandshake _ = Nothing toHandshake = HCertificateReq instance HandshakeItem ServerHelloDone where - fromHandshake HServerHelloDone = Just ServerHelloDone + fromHandshake HServerHelloDone = Just SHDone fromHandshake _ = Nothing toHandshake _ = HServerHelloDone @@ -205,7 +205,7 @@ fromHandshake _ = Nothing toHandshake (Finished f) = HFinished f -data ServerHelloDone = ServerHelloDone deriving Show +data ServerHelloDone = SHDone deriving Show data Type = THelloRequest | TClientHello | TServerHello diff --git a/test/testCIRenego.hs b/test/testCIRenego.hs --- a/test/testCIRenego.hs +++ b/test/testCIRenego.hs @@ -32,7 +32,8 @@ ] randomFrom :: [a] -> IO [a] -randomFrom [] = return [] +randomFrom [] = error "bad" +randomFrom [x] = return [x] randomFrom (x : xs) = do b <- randomIO (if b then (x :) else id) <$> randomFrom xs diff --git a/test/testDebug.hs b/test/testDebug.hs --- a/test/testDebug.hs +++ b/test/testDebug.hs @@ -33,7 +33,8 @@ ] randomFrom :: [a] -> IO [a] -randomFrom [] = return [] +randomFrom [] = error "bad" +randomFrom [x] = return [x] randomFrom (x : xs) = do b <- randomIO (if b then (x :) else id) <$> randomFrom xs