diff --git a/data/certs/geotrust_global_ca.pem b/data/certs/geotrust_global_ca.pem new file mode 100644 --- /dev/null +++ b/data/certs/geotrust_global_ca.pem @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDVDCCAjygAwIBAgIDAjRWMA0GCSqGSIb3DQEBBQUAMEIxCzAJBgNVBAYTAlVT +MRYwFAYDVQQKEw1HZW9UcnVzdCBJbmMuMRswGQYDVQQDExJHZW9UcnVzdCBHbG9i +YWwgQ0EwHhcNMDIwNTIxMDQwMDAwWhcNMjIwNTIxMDQwMDAwWjBCMQswCQYDVQQG +EwJVUzEWMBQGA1UEChMNR2VvVHJ1c3QgSW5jLjEbMBkGA1UEAxMSR2VvVHJ1c3Qg +R2xvYmFsIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEA2swYYzD9 +9BcjGlZ+W988bDjkcbd4kdS8odhM+KhDtgPpTSEHCIjaWC9mOSm9BXiLnTjoBbdq +fnGk5sRgprDvgOSJKA+eJdbtg/OtppHHmMlCGDUUna2YRpIuT8rxh0PBFpVXLVDv +iS2Aelet8u5fa9IAjbkU+BQVNdnARqN7csiRv8lVK83Qlz6cJmTM386DGXHKTubU +1XupGc1V3sjs0l44U+VcT4wt/lAjNvxm5suOpDkZALeVAjmRCw7+OC7RHQWa9k0+ +bw8HHa8sHo9gOeL6NlMTOdReJivbPagUvTLrGAMoUgRx5aszPeE4uwc2hGKceeoW +MPRfwCvocWvk+QIDAQABo1MwUTAPBgNVHRMBAf8EBTADAQH/MB0GA1UdDgQWBBTA +ephojYn7qwVkDBF9qn1luMrMTjAfBgNVHSMEGDAWgBTAephojYn7qwVkDBF9qn1l +uMrMTjANBgkqhkiG9w0BAQUFAAOCAQEANeMpauUvXVSOKVCUn5kaFOSPeCpilKIn +Z57QzxpeR+nBsqTP3UEaBU6bS+5Kb1VSsyShNwrrZHYqLizz/Tt1kL/6cdjHPTfS +tQWVYrmm3ok9Nns4d0iXrKYgjy6myQzCsplFAMfOEVEiIuCl6rYVSAlk6l5PdPcF +PseKUgzbFbS9bZvlxrFUaKnjaZC2mqUPuLk/IH2uSrW4nOQdtqvmlKXBx4Ot2/Un +hw4EbNX/3aBd7YdStysVAq45pmp06drE57xNNB6pXE0zX5IJL4hmXXeXxx12E6nV +5fEWCRE11azbJHFwLJhWC9kXtNHjUStedejV0NxPNO3CBWaAocvmMw== +-----END CERTIFICATE----- diff --git a/examples/secretServer.hs b/examples/secretServer.hs new file mode 100644 --- /dev/null +++ b/examples/secretServer.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings, PackageImports #-} + +import Control.Applicative +import Control.Monad +import "monads-tf" Control.Monad.State +import Control.Concurrent +import Data.HandleLike +import System.Environment +import Network +import Network.PeyoTLS.Server +import Network.PeyoTLS.ReadFile +import "crypto-random" Crypto.Random + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC + +main :: IO () +main = do + d : _ <- getArgs + k <- readKey $ d ++ "/localhost.sample_key" + c <- readCertificateChain [d ++ "/localhost.sample_crt"] + ca <- readCertificateStore [d ++ "/cacert.pem"] + g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG + soc <- listenOn $ PortNumber 443 + void . (`runStateT` g0) . forever $ do + (h, _, _) <- liftIO $ accept soc + g <- StateT $ return . cprgFork + liftIO . forkIO . (`run` g) $ do + p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)] + Nothing + g <- hlGetLine p + doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn + liftIO $ BSC.putStrLn g + liftIO $ print $ "secret" `BS.isInfixOf` g + if "secret" `BS.isInfixOf` g + then do setCertificateStore p $ Just ca + renegotiate p + hlPut p $ BS.concat [ + "HTTP/1.1 200 OK\r\n", + "Transfer-Encoding: chunked\r\n", + "Content-Type: text/plain\r\n\r\n", + "6\r\nSecret0\r\n\r\n" ] + else do hlPut p $ BS.concat [ + "HTTP/1.1 200 OK\r\n", + "Transfer-Encoding: chunked\r\n", + "Content-Type: text/plain\r\n\r\n", + "5\r\nHello0\r\n\r\n" ] + hlClose p + +doUntil :: Monad m => (a -> Bool) -> m a -> m [a] +doUntil p rd = rd >>= \x -> + (if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x 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.22 +version: 0.0.0.23 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -260,10 +260,12 @@ examples/eccClient.hs examples/debugServer.hs examples/renegServer.hs + examples/secretServer.hs data-dir: data data-files: certs/cacert.pem, + certs/geotrust_global_ca.pem, certs/localhost.sample_key, certs/localhost.sample_crt, certs/localhost_ecdsa.sample_key, @@ -280,7 +282,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git - tag: peyotls-0.0.0.22 + tag: peyotls-0.0.0.23 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 @@ -1,62 +1,42 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports, - TupleSections #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} -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, - readHandshake, getChangeCipherSpec, - writeHandshake, putChangeCipherSpec, - writeHandshakeNH, - HM.ValidateHandle(..), HM.handshakeValidate, - HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - ServerHelloDone(..), - ClientHello(..), ServerHello(..), SessionId(..), +module Network.PeyoTLS.Base ( + PeyotlsM, TlsM, run, SettingsS, + adGet, adGetLine, adGetContent, + HandshakeM, execHandshakeM, rerunHandshakeM, + getSettingsC, setSettingsC, getSettingsS, setSettingsS, + withRandom, randomByteString, flushAppData, + AlertLevel(..), AlertDesc(..), throwError, + debugCipherSuite, debug, + ValidateHandle(..), handshakeValidate, validateAlert, + TlsHandleBase, names, + CertSecretKey(..), isRsaKey, isEcdsaKey, + readHandshake, writeHandshake, + getChangeCipherSpec, putChangeCipherSpec, + Handshake(HHelloReq), + ClientHello(..), ServerHello(..), SessionId(..), Extension(..), + isRenegoInfo, emptyRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), - HM.getCipherSuite, HM.setCipherSuite, - CertReq(..), certificateRequest, ClientCertificateType(..), SecretKey(..), - ClientKeyExchange(..), Epms(..), - HM.generateKeys, - HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite, - DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite, - 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(..), - HM.tlsHandle, - hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_, - hlGetContentRn, - - HM.getSettings, HM.setSettings, HM.SettingsS, - getSettingsC, setSettingsC, - HM.flushAppData_, - flushAppData, - HM.pushAdBufH, - - validateAlert, - ) where + getCipherSuite, setCipherSuite, + checkClRenego, checkSvRenego, makeClRenego, makeSvRenego, + ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + SvSignSecretKey(..), SvSignPublicKey(..), + CertReq(..), certReq, ClCertType(..), + ServerHelloDone(..), + ClientKeyEx(..), Epms(..), generateKeys, + DigitallySigned(..), ClSignPublicKey(..), ClSignSecretKey(..), + handshakeHash, + RW(..), flushCipherSuite, + Side(..), finishedHash, + DhParam(..), makeEcdsaPubKey ) where -import Control.Applicative -import Control.Arrow (first, second, (***)) -import Control.Monad (liftM) +import Control.Arrow (first) +import Control.Monad (unless, liftM, ap) import "monads-tf" Control.Monad.State (gets, lift) -import qualified "monads-tf" Control.Monad.Error as E -import Data.Word (Word8) +import Data.Bits (shiftR) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) -import Numeric (readHex) import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) import qualified Data.ByteString as BS @@ -67,8 +47,8 @@ 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.RSA as RSA import qualified Crypto.PubKey.RSA.Prim as RSA +import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC @@ -76,125 +56,98 @@ 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 qualified Crypto.PubKey.HashDescr as HD +import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import Network.PeyoTLS.Types ( Extension(..), +import Network.PeyoTLS.Types ( Handshake(..), HandshakeItem(..), ClientHello(..), ServerHello(..), SessionId(..), CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertReq(..), certificateRequest, ClientCertificateType(..), - SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyExchange(..), Epms(..), - DigitallySigned(..), Finished(..) ) -import qualified Network.PeyoTLS.Run as HM ( - TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, - withRandom, randomByteString, - ValidateHandle(..), handshakeValidate, - TlsHandle_(..), ContentType(..), - names, - getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, - tlsGetContentType, tlsGet, tlsPut, tlsPutNH, - generateKeys, encryptRsa, decryptRsa, rsaPadding, - Alert(..), AlertLevel(..), AlertDesc(..), - Side(..), RW(..), handshakeHash, finishedHash, throwError, - hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_, - tGetLine_, tGetContent_, tlsGet__, - hlDebug_, hlClose_, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, - resetSequenceNumber, - - getSettings, setSettings, SettingsS, - getSettingsC, setSettingsC, - flushAppData_, - getAdBuf, - setAdBuf, - pushAdBufH, - - CertSecretKey(..), - ) -import Network.PeyoTLS.Ecdsa (blindSign, generateKs) + CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo, + ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..), + ServerHelloDone(..), ClientKeyEx(..), Epms(..), + DigitallySigned(..), ChangeCipherSpec(..), Finished(..) ) +import qualified Network.PeyoTLS.Run as RUN (finishedHash) +import Network.PeyoTLS.Run ( + TlsM, run, TlsHandleBase(..), names, + hsGet, hsPut, updateHash, ccsGet, ccsPut, + adGet, adGetLine, adGetContent, + HandshakeM, execHandshakeM, rerunHandshakeM, + withRandom, randomByteString, flushAppData, + SettingsS, getSettingsS, setSettingsS, + getSettingsC, setSettingsC, + getCipherSuite, setCipherSuite, + CertSecretKey(..), isRsaKey, isEcdsaKey, + getClFinished, getSvFinished, setClFinished, setSvFinished, + RW(..), flushCipherSuite, generateKeys, + Side(..), handshakeHash, -- finishedHash, + ValidateHandle(..), handshakeValidate, validateAlert, + AlertLevel(..), AlertDesc(..), debugCipherSuite, throwError ) +import Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey) --- import Network.PeyoTLS.CertSecretKey +moduleName :: String +moduleName = "Network.PeyoTLS.Base" -type PeyotlsM = HM.TlsM Handle SystemRNG +type PeyotlsM = TlsM Handle SystemRNG -debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g () +debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g () debug p x = do - h <- gets $ HM.tlsHandle . fst + h <- gets $ tlsHandle . fst lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x -readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi +readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi readHandshake = do - cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType - hs <- case cnt of - CHandshake HHelloReq -> readHandshake - CHandshake hs -> return hs - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: not handshake: " ++ show cnt - case fromHandshake hs of - Just i -> return i - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.readHandshake: type mismatch " ++ show hs - -writeHandshake, writeHandshakeNH :: - (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g () -writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake -writeHandshakeNH = uncurry HM.tlsPutNH . encodeContent . CHandshake . toHandshake - -data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show + bs <- hsGet + case B.decode bs of + Right HHelloReq -> readHandshake + Right hs -> case fromHandshake hs of + Just i -> updateHash bs >> return i + _ -> throwError ALFatal ADUnexpectedMessage $ + moduleName ++ ".readHandshake: " ++ show hs + Left em -> throwError ALFatal ADInternalError $ + moduleName ++ ".readHandshake: " ++ em -instance B.Bytable ChangeCipherSpec where - decode bs = case BS.unpack bs of - [1] -> Right ChangeCipherSpec - [w] -> Right $ ChangeCipherSpecRaw w - _ -> Left "HandshakeBase: ChangeCipherSpec.decode" - encode ChangeCipherSpec = BS.pack [1] - encode (ChangeCipherSpecRaw w) = BS.pack [w] +writeHandshake:: (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HandshakeM h g () +writeHandshake hi = + hsPut bs >> case hs of HHelloReq -> return (); _ -> updateHash bs + where hs = toHandshake hi; bs = B.encode hs -getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () +getChangeCipherSpec :: (HandleLike h, CPRG g) => HandshakeM h g () getChangeCipherSpec = do - cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType - case cnt of - CCCSpec ChangeCipherSpec -> return () - _ -> HM.throwError - HM.ALFatal HM.ADUnexpectedMessage $ - "HandshakeBase.getChangeCipherSpec: " ++ - "not change cipher spec: " ++ - show cnt - HM.resetSequenceNumber HM.Read + w <- ccsGet + case B.decode $ BS.pack [w] of + Right ChangeCipherSpec -> return () + _ -> throwError ALFatal ADUnexpectedMessage $ + moduleName ++ ".getChangeCipherSpec: not change cipher spec" -putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () -putChangeCipherSpec = do - uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec - HM.resetSequenceNumber HM.Write +putChangeCipherSpec :: (HandleLike h, CPRG g) => HandshakeM h g () +putChangeCipherSpec = ccsPut . (\[w] -> w) . BS.unpack $ B.encode ChangeCipherSpec -data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake - deriving Show +finishedHash :: (HandleLike h, CPRG g) => Side -> HandshakeM h g Finished +finishedHash s = Finished `liftM` do + fh <- RUN.finishedHash s + case s of Client -> setClFinished fh; Server -> setSvFinished fh + return fh -readContent :: Monad m => (Bool -> Int -> m BS.ByteString) -> HM.ContentType -> m Content -readContent rd HM.CTCCSpec = - (CCCSpec . either error id . B.decode) `liftM` rd True 1 -readContent rd HM.CTAlert = - ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd True 2 -readContent rd HM.CTHandshake = CHandshake `liftM` do - t <- rd True 1 - len <- rd (t /= "\0") 3 --- (t, len) <- (,) `liftM` rd True 1 `ap` rd True 3 - body <- rd True . either error id $ B.decode len - return . either error id . B.decode $ BS.concat [t, len, body] -readContent _ _ = undefined +checkClRenego, checkSvRenego :: HandleLike h => Extension -> HandshakeM h g () +checkClRenego (ERenegoInfo ri) = do + ok <- (ri ==) `liftM` getClFinished + unless ok . throwError ALFatal ADHsFailure $ + moduleName ++ ".checkClRenego: renego info is not match" +checkClRenego _ = throwError ALFatal ADInternalError $ + moduleName ++ ".checkClRenego: not renego info" +checkSvRenego (ERenegoInfo ri) = do + ok <- (ri ==) `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) + unless ok . throwError ALFatal ADHsFailure $ + moduleName ++ ".checkSvRenego: renego info is not match" +checkSvRenego _ = throwError ALFatal ADInternalError $ + moduleName ++ ".checkSvRenego: not renego info" -encodeContent :: Content -> (HM.ContentType, BS.ByteString) -encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs) -encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad]) -encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss) +makeClRenego, makeSvRenego :: HandleLike h => HandshakeM h g Extension +makeClRenego = ERenegoInfo `liftM` getClFinished +makeSvRenego = + ERenegoInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished) class DhParam b where type Secret b @@ -208,285 +161,123 @@ type Public DH.Params = DH.PublicNumber generateSecret = flip DH.generatePrivate calculatePublic = DH.calculatePublic - calculateShared ps sn pn = B.encode . - (\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn - -dh3072Modp :: DH.Params -dh3072Modp = DH.Params p 2 - where [(p, "")] = readHex $ - "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++ - "29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++ - "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++ - "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++ - "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++ - "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++ - "83655d23dca3ad961c62f356208552bb9ed529077096966d" ++ - "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++ - "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++ - "de2bcbf6955817183995497cea956ae515d2261898fa0510" ++ - "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++ - "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++ - "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++ - "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++ - "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++ - "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff" + calculateShared = + (((B.encode . (\(DH.SharedKey s) -> s)) .) .) . DH.getShared instance DhParam ECC.Curve where type Secret ECC.Curve = Integer type Public ECC.Curve = ECC.Point - generateSecret c = getRangedInteger 32 1 (n - 1) - where n = ECC.ecc_n $ ECC.common_curve c - calculatePublic cv sn = - ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv + generateSecret c = rec + where + rec g = let + (bs, g') = cprgGenerate bl g + i = either error id $ B.decode bs in + if 1 <= i && i <= mx then (i, g') else rec g' + bl = len mx `div` 8 + signum (len mx `mod` 8) + mx = ECC.ecc_n (ECC.common_curve c) - 1 + len 0 = 0; len i = succ . len $ i `shiftR` 1 + calculatePublic cv sn = ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv calculateShared cv sn pp = let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x -getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g) -getRangedInteger b mn mx g = let - (n, g') = first (either error id . B.decode) $ cprgGenerate b g in - if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g' -secp256r1 :: ECC.Curve -secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 - -finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished -finishedHash s = (Finished `liftM`) $ do - fh <- HM.finishedHash s - case s of - HM.Client -> HM.setClientFinished fh - 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 - hlPut = HM.hlPut_ - hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) - . HM.tlsGet__ . (, undefined) - hlGetLine = ($) <$> checkAppData <*> HM.tGetLine - hlGetContent = ($) <$> checkAppData <*> HM.tGetContent - hlDebug = HM.hlDebug_ - hlClose = HM.hlClose_ - -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" - (HM.CTHandshake, hs) -> do - lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n" - lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack - . (++ "\n") $ show hs - lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack - . (++ "\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" - -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 -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 rn t n = do - bf <- HM.getAdBuf t - if BS.length bf >= n - then do let (ret, rest) = BS.splitAt n bf - HM.setAdBuf t rest - return ret - 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.TlsM h g BS.ByteString -hlGetLineRn rn t = do - bf <- HM.getAdBuf t - if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf - then do let (ret, rest) = splitOneLine bf - HM.setAdBuf t $ BS.tail rest - return ret - else (bf `BS.append`) `liftM` hlGetLineRn_ rn t - -splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString) -splitOneLine bs = case BSC.span (/= '\r') bs of - (_, "") -> second BS.tail $ BSC.span (/= '\n') bs - (l, ls) -> (l, dropRet ls) - -dropRet :: BS.ByteString -> BS.ByteString -dropRet bs = case BSC.uncons bs of - Just ('\r', bs') -> case BSC.uncons bs' of - Just ('\n', bs'') -> bs'' - _ -> bs' - _ -> 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 -hlGetContentRn rn t = do - bf <- HM.getAdBuf t - if BS.null bf - then hlGetContentRn_ rn t - else do HM.setAdBuf t "" - return bf - -flushAppData :: (HandleLike h, CPRG g) => HM.HandshakeM h g Bool -flushAppData = uncurry (>>) . (HM.pushAdBufH *** return) =<< HM.flushAppData_ - -isEcdsaKey :: HM.CertSecretKey -> Bool -isEcdsaKey (HM.EcdsaKey _) = True -isEcdsaKey _ = False - -isRsaKey :: HM.CertSecretKey -> Bool -isRsaKey (HM.RsaKey _) = True -isRsaKey _ = False - -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" +sha1, sha256 :: ASN1.ASN1 +sha1 = ASN1.OID [1, 3, 14, 3, 2, 26] +sha256 = ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1] -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" +padding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString +padding pk bs = case RSA.padSignature (RSA.public_size pk) $ + HD.digestToASN1 HD.hashDescrSHA256 bs of + Left m -> error $ show m; Right pd -> pd class SvSignPublicKey pk where - svpAlgorithm :: pk -> SignAlg - verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool + sspAlgorithm :: pk -> SignAlg + ssVerify :: 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 + sspAlgorithm _ = Rsa + ssVerify ha pk sn m = oid == oid0 && e == hs m + where + (hs, oid0) = case ha of + Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256) + _ -> error $ moduleName ++ ": RSA.PublicKey.ssVerify" + (e, 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, + i, ASN1.Null, ASN1.End ASN1.Sequence, + ASN1.OctetString o, + ASN1.End ASN1.Sequence ] -> (o, i) + em -> error $ + moduleName ++ ": RSA.PublicKey.ssVerify" ++ show em 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" + sspAlgorithm _ = Ecdsa + ssVerify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode + ssVerify Sha256 pk = + ECDSA.verify SHA256.hash pk . either error id . B.decode + ssVerify _ _ = error $ moduleName ++ ": ECDSA.PublicKey.verify" -class SecretKey sk where +class SvSignSecretKey sk where type Blinder sk + sssAlgorithm :: sk -> SignAlg generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g) - sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString - signatureAlgorithm :: sk -> SignAlg + ssSign :: sk -> HashAlg -> Blinder sk -> BS.ByteString -> BS.ByteString -instance SecretKey RSA.PrivateKey where +instance SvSignSecretKey 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, + sssAlgorithm _ = Rsa + generateBlinder sk g = + RSA.generateBlinder g . RSA.public_n $ RSA.private_pub sk + ssSign sk ha bl m = RSA.dp (Just bl) sk e + where + (hs, oid) = first ($ m) $ case ha of + Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256) + _ -> error $ moduleName ++ ": RSA.PrivateKey.ssSign" + b = ASN1.encodeASN1' ASN1.DER [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 + ASN1.OctetString hs, ASN1.End ASN1.Sequence] + e = BS.concat ["\0\1", BS.replicate (s - BS.length b) 255, "\0", b] + s = RSA.public_size (RSA.private_pub sk) - 3 -instance SecretKey ECDSA.PrivateKey where +instance SvSignSecretKey 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) + sssAlgorithm _ = Ecdsa + generateBlinder _ g = (bl, g') where + bl = either error id $ B.decode bs; (bs, g') = cprgGenerate 32 g + ssSign sk ha bl m = B.encode $ blindSign bl hs sk (makeKs (hs, bls) q x m) m + where (hs, bls) = case ha of - Sha1 -> (SHA1.hash, 64) - Sha256 -> (SHA256.hash, 64) - _ -> error $ "HandshakeBase: " ++ - "not implemented bulk encryption type" + Sha1 -> (SHA1.hash, 64); Sha256 -> (SHA256.hash, 64) + _ -> error $ moduleName ++ ": ECDSA.PrivateKey.ssSign" q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk - signatureAlgorithm _ = Ecdsa +class ClSignPublicKey pk where + cspAlgorithm :: pk -> SignAlg + csVerify :: pk -> BS.ByteString -> BS.ByteString -> Bool + +instance ClSignPublicKey RSA.PublicKey where + cspAlgorithm _ = Rsa + csVerify pk s h = RSA.ep pk s == padding pk h + +instance ClSignPublicKey ECDSA.PublicKey where + cspAlgorithm _ = Ecdsa + csVerify pk = ECDSA.verify id pk . either error id . B.decode + class ClSignSecretKey sk where + cssAlgorithm :: sk -> (HashAlg, SignAlg) 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) + cssAlgorithm _ = (Sha256, Rsa) + csSign sk m = RSA.dp Nothing sk $ padding (RSA.private_pub sk) m instance ClSignSecretKey ECDSA.PrivateKey where - csSign sk m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m + cssAlgorithm _ = (Sha256, Ecdsa) + csSign sk m = enc $ blindSign 0 id sk (makeKs (SHA256.hash, 64) q x m) m where q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk @@ -494,19 +285,3 @@ 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/CertSecretKey.hs b/src/Network/PeyoTLS/CertSecretKey.hs --- a/src/Network/PeyoTLS/CertSecretKey.hs +++ b/src/Network/PeyoTLS/CertSecretKey.hs @@ -1,4 +1,5 @@ -module Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) where +module Network.PeyoTLS.CertSecretKey ( + CertSecretKey(..), isRsaKey, isEcdsaKey ) where import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA @@ -7,3 +8,11 @@ = RsaKey { rsaKey :: RSA.PrivateKey } | EcdsaKey { ecdsaKey :: ECDSA.PrivateKey } deriving Show + +isEcdsaKey :: CertSecretKey -> Bool +isEcdsaKey (EcdsaKey _) = True +isEcdsaKey _ = False + +isRsaKey :: CertSecretKey -> Bool +isRsaKey (RsaKey _) = True +isRsaKey _ = False 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,8 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.PeyoTLS.Certificate ( - CertReq(..), certificateRequest, ClientCertificateType(..), - ClientKeyExchange(..), DigitallySigned(..)) where + CertReq(..), certReq, ClCertType(..), + ClientKeyEx(..), DigitallySigned(..)) where import Control.Applicative ((<$>), (<*>)) import Data.Word (Word8, Word16) @@ -36,12 +36,12 @@ return . X509.CertificateChain $ cs Left (n, err) -> fail $ show n ++ " " ++ err -data CertReq = CertReq [ClientCertificateType] [(HashAlg, SignAlg)] [X509.DistinguishedName] +data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName] deriving Show -certificateRequest :: [ClientCertificateType] -> [(HashAlg, SignAlg)] -> +certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> X509.CertificateStore -> CertReq -certificateRequest t a = CertReq t a +certReq t a = CertReq t a . map (X509.certIssuerDN . X509.signedObject . X509.getSigned) . X509.listCertificates @@ -63,23 +63,23 @@ either (fail . show) (return . fst) $ ASN1.fromASN1 a1 return $ CertReq t a n -data ClientCertificateType = CTRsaSign | CTEcdsaSign | CTRaw Word8 +data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq) -instance B.Bytable ClientCertificateType where +instance B.Bytable ClCertType where encode CTRsaSign = "\x01" encode CTEcdsaSign = "\x40" encode (CTRaw w) = BS.pack [w] decode bs = case BS.unpack bs of [w] -> Right $ case w of 1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w - _ -> Left "Certificate: ClientCertificateType.decode" + _ -> Left "Certificate: ClCertType.decode" -data ClientKeyExchange = ClientKeyExchange BS.ByteString deriving Show +data ClientKeyEx = ClientKeyEx BS.ByteString deriving Show -instance B.Bytable ClientKeyExchange where - decode = Right . ClientKeyExchange - encode (ClientKeyExchange epms) = epms +instance B.Bytable ClientKeyEx where + decode = Right . ClientKeyEx + encode (ClientKeyEx epms) = epms data DigitallySigned = DigitallySigned (HashAlg, SignAlg) BS.ByteString 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,13 +1,29 @@ +{-| + +Module : Network.PeyoTLS.Server +Copyright : (c) Yoshikuni Jujo, 2014 +License : BSD3 +Maintainer : PAF01143@nifty.ne.jp +Stability : Experimental + +-} + {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Client ( - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names, + -- * Basic + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, + -- * Renegotiation + renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, + -- * Cipher Suite CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (when, unless, liftM, ap) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import "monads-tf" Control.Monad.Error.Class (strMsg) +import Data.Maybe (fromMaybe) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) @@ -20,42 +36,46 @@ import qualified Crypto.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as RSA +import qualified "monads-tf" Control.Monad.Error as E + import qualified Network.PeyoTLS.Base as BASE (names) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, getSettingsC, setSettingsC, - hlGetRn, hlGetLineRn, hlGetContentRn, + adGet, adGetLine, adGetContent, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, flushAppData, AlertLevel(..), AlertDesc(..), throwError, ValidateHandle(..), handshakeValidate, validateAlert, - TlsHandle_, CertSecretKey(..), + TlsHandleBase, CertSecretKey(..), readHandshake, writeHandshake, getChangeCipherSpec, putChangeCipherSpec, - ClientHello(..), ServerHello(..), SessionId(..), eRenegoInfo, + ClientHello(..), ServerHello(..), SessionId(..), isRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), setCipherSuite, - checkServerRenego, makeClientRenego, + checkSvRenego, makeClRenego, ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..), - CertReq(..), ClientCertificateType(..), + CertReq(..), ClCertType(..), ServerHelloDone(..), - ClientKeyExchange(..), Epms(..), generateKeys, encryptRsa, + ClientKeyEx(..), Epms(..), generateKeys, -- encryptRsa, DigitallySigned(..), ClSignSecretKey(..), handshakeHash, Side(..), RW(..), finishedHash, flushCipherSuite, DhParam(..), makeEcdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandle_ h g } deriving Show +newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandleBase 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 + hlGet = adGet rehandshake . tlsHandleC + hlGetLine = adGetLine rehandshake . tlsHandleC + hlGetContent = adGetContent rehandshake . tlsHandleC hlDebug (TlsHandleC t) = hlDebug t hlClose (TlsHandleC t) = hlClose t @@ -78,7 +98,25 @@ clientHello cscl >>= \cr -> flushAppData >>= flip when (handshake crts ca cr) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () +setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [CipherSuite] -> TlsM h g () +setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do + (_, crts, cs) <- getSettingsC + setSettingsC (cscl, crts, cs) + +setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () +setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do + (cscl, _, cs) <- getSettingsC + setSettingsC (cscl, crts, cs) + +setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + X509.CertificateStore -> TlsM h g () +setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do + (cscl, crts, _) <- getSettingsC + setSettingsC (cscl, crts, cs) + +rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do (cscl, crts, ca) <- getSettingsC handshake crts ca =<< clientHello cscl @@ -89,7 +127,7 @@ cr <- randomByteString 32 ((>>) <$> writeHandshake <*> debug "low") . ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull] - . Just . (: []) =<< makeClientRenego + . Just . (: []) =<< makeClRenego return cr handshake :: (ValidateHandle h, CPRG g) => @@ -116,8 +154,8 @@ CompMethodNull -> return () _ -> throwError ALFatal ADHsFailure $ moduleName ++ ".serverHello: only compression method null" - case listToMaybe . mapMaybe eRenegoInfo $ fromMaybe [] e of - Just ri -> checkServerRenego ri + case find isRenegoInfo $ fromMaybe [] e of + Just ri -> checkSvRenego ri _ -> throwError ALFatal ADInsufficientSecurity $ moduleName ++ ".serverHello: require secure renegotiation" setCipherSuite cs @@ -141,17 +179,22 @@ writeHandshake . Epms =<< encryptRsa pk pms finishHandshake crt +encryptRsa :: (HandleLike h, CPRG g) => + RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString +encryptRsa pk p = either (E.throwError . strMsg . show) return =<< + withRandom (\g -> RSA.encrypt g pk p) + 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 rs crts ca = do - cc@(X509.CertificateChain cs) <- readHandshake + cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc unless (null vr) . throwError ALFatal (validateAlert vr) $ moduleName ++ ".succeed: validate failure" - case X509.certPubKey . X509.signedObject . X509.getSigned $ head cs of + case X509.certPubKey . X509.signedObject $ X509.getSigned c of X509.PubKeyRSA pk -> succeed t pk rs crts X509.PubKeyECDSA cv pt -> succeed t (makeEcdsaPubKey cv pt) rs crts _ -> throwError ALFatal ADHsFailure $ @@ -164,14 +207,14 @@ succeed t pk rs@(cr, sr) crts = do (ps, pv, ha, sa, sn) <- serverKeyExchange let _ = ps `asTypeOf` t - unless (sa == svpAlgorithm pk) . throwError ALFatal ADHsFailure $ + unless (sa == sspAlgorithm pk) . throwError ALFatal ADHsFailure $ pre ++ "sign algorithm unmatch" - unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) . + unless (ssVerify 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 rs $ calculateShared ps sv pv - writeHandshake . ClientKeyExchange . B.encode $ calculatePublic ps sv + writeHandshake . ClientKeyEx . B.encode $ calculatePublic ps sv finishHandshake crt where pre = moduleName ++ ".succeed: " @@ -202,7 +245,7 @@ _ -> throwError ALFatal ADUnknownCa $ moduleName ++ ".clientCertificate: no certificate" -isMatchedCert :: [ClientCertificateType] -> [(HashAlg, SignAlg)] -> +isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] -> [X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd where @@ -210,9 +253,10 @@ 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) && + ccrt (X509.CertificateChain cs@(c : _)) = + cpk (X509.certPubKey $ obj c) && not (null . intersect dn $ map (X509.certIssuerDN . obj) cs) + ccrt _ = error $ moduleName ++ ".isMatchedCert: empty certificate chain" cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False finishHandshake :: (HandleLike h, CPRG g) => @@ -221,9 +265,9 @@ hs <- handshakeHash case fst <$> crt of Just (RsaKey sk) -> writeHandshake $ - DigitallySigned (csAlgorithm sk) $ csSign sk hs + DigitallySigned (cssAlgorithm sk) $ csSign sk hs Just (EcdsaKey sk) -> writeHandshake $ - DigitallySigned (csAlgorithm sk) $ csSign sk hs + DigitallySigned (cssAlgorithm sk) $ csSign sk hs _ -> return () putChangeCipherSpec >> flushCipherSuite Write writeHandshake =<< finishedHash Client diff --git a/src/Network/PeyoTLS/Ecdsa.hs b/src/Network/PeyoTLS/Ecdsa.hs --- a/src/Network/PeyoTLS/Ecdsa.hs +++ b/src/Network/PeyoTLS/Ecdsa.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.PeyoTLS.Ecdsa (blindSign, generateKs) where +module Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey) where import Control.Applicative ((<$>), (<*>)) import Data.Maybe (mapMaybe) @@ -18,6 +18,9 @@ import qualified Data.ASN1.Encoding as ASN1 import qualified Data.ASN1.BinaryEncoding as ASN1 +moduleName :: String +moduleName = "Newtork.PeyoTLS.Ecdsa" + instance B.Bytable ECDSA.Signature where encode (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [ ASN1.Start ASN1.Sequence, @@ -55,7 +58,8 @@ -- RFC 6979 -generateKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer] +makeKs, generateKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer] +makeKs = generateKs generateKs hsbl@(hs, _) q x m = filter ((&&) <$> (> 0) <*> (< q)) . uncurry (createKs hsbl q) . initializeKV hsbl q x $ hs m @@ -128,3 +132,13 @@ bits2octets :: Integer -> BS.ByteString -> BS.ByteString bits2octets q bs = int2octets q $ bits2int q bs `mod` q + +makeEcdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey +makeEcdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ decodePoint xy + +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" 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(..), + TlsHandleBase(..), RW(..), Side(..), ContentType(..), CipherSuite(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, @@ -23,7 +23,9 @@ flushAppData, getAdBufT, setAdBufT, - CertSecretKey(..), + CertSecretKey(..), isRsaKey, isEcdsaKey, + + updateHash, ) where import Prelude hiding (read) @@ -59,18 +61,18 @@ Settings, getSettings, setSettings, SettingsS, getInitSet, setInitSet, - CertSecretKey(..), + CertSecretKey(..), isRsaKey, isEcdsaKey, ) import qualified Network.PeyoTLS.Crypto as CT ( makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) -data TlsHandle_ h g = TlsHandle_ { +data TlsHandleBase h g = TlsHandleBase { clientId :: PartnerId, tlsHandle :: h, names :: [String] } deriving Show -type HandleHash h g = (TlsHandle_ h g, SHA256.Ctx) +type HandleHash h g = (TlsHandleBase h g, SHA256.Ctx) data Side = Server | Client deriving (Show, Eq) @@ -81,15 +83,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 (TlsHandleBase h g) newHandle h = do s <- get let (i, s') = newPartnerId s put s' - return TlsHandle_ { + return TlsHandleBase { clientId = i, tlsHandle = h, names = [] } -getContentType :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ContentType +getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g ContentType getContentType t = do ct <- fst `liftM` getBuf (clientId t) (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do @@ -98,41 +100,47 @@ return ct' flushAppData :: (HandleLike h, CPRG g) => - TlsHandle_ h g -> TlsM h g (BS.ByteString, Bool) + TlsHandleBase h g -> TlsM h g (BS.ByteString, Bool) flushAppData t = do + lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAppData\n" ct <- getContentType t + lift . lift $ hlDebug (tlsHandle t) "low" "after getContentType\n" case ct of CTAppData -> do - (_, ad) <- tGetContent t + lift . lift $ hlDebug (tlsHandle t) "low" "CTAppData\n" + (ct', ad) <- tGetContent t + lift . lift $ hlDebug (tlsHandle t) "low" . + BSC.pack $ show (ct', ad) ++ "\n" (bs, b) <- flushAppData t + lift . lift . hlDebug (tlsHandle t) "low" . + BSC.pack $ show bs return (ad `BS.append` bs, b) -- liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t CTAlert -> do ((_, a), _) <- tlsGet True (t, undefined) 2 + lift . lift $ hlDebug (tlsHandle t) "low" . + BSC.pack $ show a case a of "\1\0" -> return ("", False) _ -> throwError "flushAppData" - _ -> return ("", True) + _ -> do lift . lift $ hlDebug (tlsHandle t) "low" . + BSC.pack $ show ct + return ("", True) tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g -> Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g) tlsGet b hh@(t, _) n = do r@(ct, bs) <- buffered t n (r ,) `liftM` case (ct, b, bs) of - (CTHandshake, _, "\0") -> return hh - (CTHandshake, True, _) - | "\0\0\0\0" `BS.isPrefixOf` bs -> - updateHash hh $ BS.drop 4 bs - | otherwise -> updateHash hh bs _ -> return hh -tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) -> +tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandleBase 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) + TlsHandleBase 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 @@ -147,8 +155,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) => (TlsHandleBase h g -> TlsM h g ()) -> + TlsHandleBase h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered_ rn t n = do ct0 <- getContentType t case ct0 of @@ -164,7 +172,7 @@ second (b `BS.append`) `liftM` buffered_ rn t rl splitRetBuf :: HandleLike h => - TlsHandle_ h g -> Int -> ContentType -> BS.ByteString -> + TlsHandleBase 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 @@ -172,33 +180,33 @@ return (ct, ret) getWholeWithCt :: (HandleLike h, CPRG g) => - TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) + TlsHandleBase 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 "TlsHandleBase.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) => TlsHandleBase 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 + "TlsHandleBase.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 + TlsHandleBase 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 => TlsHandleBase 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 @@ -209,7 +217,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 "TlsHandleBase.decrypt: not implement bulk encryption" either (throwError . strMsg) return $ CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e @@ -223,10 +231,9 @@ flush t >> setWBuf (clientId t) (ct, p) | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p) case (ct, b) of - (CTHandshake, True) -> updateHash hh p _ -> return hh -flush :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g () +flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g () flush t = do (bct, bp) <- getWBuf $ clientId t setWBuf (clientId t) (CTNull, "") @@ -236,12 +243,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 + TlsHandleBase 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) => TlsHandleBase 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 @@ -252,14 +259,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 "TlsHandleBase.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 => TlsHandleBase h g -> RW -> TlsM h g Word64 updateSequenceNumber t rw = do ks <- getKeys $ clientId t (sn, cs) <- case rw of @@ -272,12 +279,12 @@ Write -> succWriteSn $ clientId t return sn -resetSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g () +resetSequenceNumber :: HandleLike h => TlsHandleBase 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 => TlsHandleBase 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 @@ -307,7 +314,7 @@ Read -> flushCipherSuiteRead Write -> flushCipherSuiteWrite -debugCipherSuite :: HandleLike h => TlsHandle_ h g -> String -> TlsM h g () +debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> TlsM h g () debugCipherSuite t a = do k <- getKeys $ clientId t thlDebug (tlsHandle t) "high" . BSC.pack @@ -324,19 +331,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) => TlsHandleBase 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 () + TlsHandleBase 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) => TlsHandleBase 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) + TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) tGetLine t = do (bct, bp) <- getBuf $ clientId t case splitLine bp of @@ -345,8 +352,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) => (TlsHandleBase h g -> TlsM h g ()) -> + TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString) tGetLine_ rn t = do ct <- getContentType t case ct of @@ -354,7 +361,7 @@ _ -> do (bct, bp) <- getBuf $ clientId t case splitLine bp of Just (l, ls) -> do - setBuf (clientId t) (bct, ls) + setBuf (clientId t) (if BS.null ls then CTNull else bct, ls) return (bct, l) _ -> do cp <- getWholeWithCt t setBuf (clientId t) cp @@ -375,36 +382,36 @@ _ -> Nothing tGetContent :: (HandleLike h, CPRG g) => - TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) + TlsHandleBase 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 => TlsHandleBase 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 => TlsHandleBase h g -> BS.ByteString -> TlsM h g () setClientFinishedT = setClientFinished . clientId setServerFinishedT = setServerFinished . clientId -getSettingsT :: HandleLike h => TlsHandle_ h g -> TlsM h g Settings +getSettingsT :: HandleLike h => TlsHandleBase h g -> TlsM h g Settings getSettingsT = getSettings . clientId -getInitSetT :: HandleLike h => TlsHandle_ h g -> TlsM h g SettingsS +getInitSetT :: HandleLike h => TlsHandleBase h g -> TlsM h g SettingsS getInitSetT = getInitSet . clientId -setSettingsT :: HandleLike h => TlsHandle_ h g -> Settings -> TlsM h g () +setSettingsT :: HandleLike h => TlsHandleBase h g -> Settings -> TlsM h g () setSettingsT = setSettings . clientId -setInitSetT :: HandleLike h => TlsHandle_ h g -> SettingsS -> TlsM h g () +setInitSetT :: HandleLike h => TlsHandleBase h g -> SettingsS -> TlsM h g () setInitSetT = setInitSet . clientId -getAdBufT :: HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString +getAdBufT :: HandleLike h => TlsHandleBase h g -> TlsM h g BS.ByteString getAdBufT = getAdBuf . clientId -setAdBufT :: HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g () +setAdBufT :: HandleLike h => TlsHandleBase 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 @@ -19,7 +19,7 @@ getClientFinished, setClientFinished, getServerFinished, setServerFinished, - S.CertSecretKey(..), + S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey, ) where import Control.Monad (liftM) @@ -48,7 +48,7 @@ getServerFinished, setServerFinished, SettingsS, Settings, - CertSecretKey(..), + CertSecretKey(..), isRsaKey, isEcdsaKey, ) type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h)) 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 @@ -1,38 +1,44 @@ {-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-} module Network.PeyoTLS.Run ( + updateHash, + hsGet, hsPut, + ccsGet, ccsPut, + adGet, adGetLine, adGetContent, + TH.isRsaKey, TH.isEcdsaKey, + checkAppData, TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, - ValidateHandle(..), handshakeValidate, - TH.TlsHandle_(..), TH.ContentType(..), + ValidateHandle(..), handshakeValidate, validateAlert, + TH.TlsHandleBase(..), TH.ContentType(..), getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, tlsGetContentType, tlsGet, tlsPut, tlsPutNH, - generateKeys, encryptRsa, decryptRsa, rsaPadding, + generateKeys, TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..), TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError, TH.hlPut_, TH.hlDebug_, TH.hlClose_, TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__, tGetLine_, tGetContent_, - getClientFinished, setClientFinished, - getServerFinished, setServerFinished, + getClFinished, getSvFinished, setClFinished, setSvFinished, resetSequenceNumber, - getSettings, setSettings, TH.SettingsS, + getSettingsS, setSettingsS, TH.SettingsS, getSettingsC, setSettingsC, TH.Settings, - flushAppData_, + flushAppData, getAdBuf, setAdBuf, - pushAdBufH, + pushAdBuf, TH.CertSecretKey(..) ) where import Prelude hiding (read) +import Data.Word import Control.Applicative import qualified Data.ASN1.Types as ASN1 -import Control.Arrow (first) +import Control.Arrow (first, second, (***)) import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift) import "monads-tf" Control.Monad.State ( @@ -44,18 +50,17 @@ import "crypto-random" Crypto.Random (CPRG) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 import qualified Data.X509.CertificateStore as X509 import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.PubKey.HashDescr as HD -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Network.PeyoTLS.Handle as TH ( + updateHash, TlsM, Alert(..), AlertLevel(..), AlertDesc(..), run, withRandom, randomByteString, - TlsHandle_(..), ContentType(..), + TlsHandleBase(..), ContentType(..), newHandle, getContentType, tlsGet, tlsPut, generateKeys, debugCipherSuite, getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, @@ -73,24 +78,53 @@ getAdBufT, setAdBufT, - CertSecretKey(..), + CertSecretKey(..), isRsaKey, isEcdsaKey, ) +import qualified Codec.Bytable.BigEndian as B + +moduleName :: String +moduleName = "Network.PeyoTLS.Run" + +instance (HandleLike h, CPRG g) => HandleLike (TH.TlsHandleBase h g) where + type HandleMonad (TH.TlsHandleBase h g) = TH.TlsM h g + type DebugLevel (TH.TlsHandleBase h g) = DebugLevel h + hlPut = TH.hlPut_ + hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) + . tlsGet__ . (, undefined) + hlGetLine = ($) <$> checkAppData <*> TH.tGetLine + hlGetContent = ($) <$> checkAppData <*> TH.tGetContent + hlDebug = TH.hlDebug_ + hlClose = TH.hlClose_ + +checkAppData :: (HandleLike h, CPRG g) => TH.TlsHandleBase h g -> + TH.TlsM h g (TH.ContentType, BS.ByteString) -> TH.TlsM h g BS.ByteString +checkAppData t m = m >>= \cp -> case cp of + (TH.CTAppData, ad) -> return ad + (TH.CTAlert, "\SOH\NUL") -> do + _ <- tlsPut_ (t, undefined) TH.CTAlert "\SOH\NUL" + E.throwError . strMsg $ + moduleName ++ ".checkAppData: EOF" + (TH.CTHandshake, _) -> E.throwError "bad" + _ -> do _ <- tlsPut_ (t, undefined) TH.CTAlert "\2\10" + E.throwError . strMsg $ + moduleName ++ ".checkAppData: not application data" + resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g () 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.TlsHandleBase h g -> TH.TlsM h g ()) -> + (TH.TlsHandleBase h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandleBase 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.TlsHandleBase h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandleBase 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.TlsHandleBase h g -> TH.TlsM h g ()) -> + TH.TlsHandleBase h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) tGetLine_ = TH.tGetLine_ flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool) @@ -103,22 +137,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.TlsHandleBase h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandleBase 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.TlsHandleBase 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.TlsHandleBase 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.TlsHandleBase 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 @@ -131,6 +165,13 @@ validate :: h -> X509.CertificateStore -> X509.CertificateChain -> HandleMonad h [X509.FailedReason] +validateAlert :: [X509.FailedReason] -> TH.AlertDesc +validateAlert vr + | X509.UnknownCA `elem` vr = TH.ADUnknownCa + | X509.Expired `elem` vr = TH.ADCertificateExpired + | X509.InFuture `elem` vr = TH.ADCertificateExpired + | otherwise = TH.ADCertificateUnknown + instance ValidateHandle Handle where validate _ cs (X509.CertificateChain cc) = X509.validate X509.HashSHA256 X509.defaultHooks @@ -196,53 +237,53 @@ k <- lift $ TH.generateKeys t p cs cr sr pms lift $ TH.setKeys (TH.clientId t) k -encryptRsa :: (HandleLike h, CPRG g) => - RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString -encryptRsa pk p = either (E.throwError . strMsg . show) return =<< - withRandom (\g -> RSA.encrypt g pk p) - -decryptRsa :: (HandleLike h, CPRG g) => - RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString -decryptRsa sk e = either (E.throwError . strMsg . show) return =<< - withRandom (\g -> RSA.decryptSafer g sk e) - -rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString -rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $ - HD.digestToASN1 HD.hashDescrSHA256 bs of - Right pd -> pd; Left m -> error $ show m - handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString handshakeHash = get >>= lift . TH.handshakeHash finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString finishedHash p = get >>= lift . flip TH.finishedHash p -getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString -getClientFinished = gets fst >>= lift . TH.getClientFinishedT -getServerFinished = gets fst >>= lift . TH.getServerFinishedT +getClFinished, getSvFinished :: HandleLike h => HandshakeM h g BS.ByteString +getClFinished = gets fst >>= lift . TH.getClientFinishedT +getSvFinished = gets fst >>= lift . TH.getServerFinishedT -setClientFinished, setServerFinished :: - HandleLike h => BS.ByteString -> HandshakeM h g () -setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf -setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf +setClFinished, setSvFinished :: HandleLike h => BS.ByteString -> HandshakeM h g () +setClFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf +setSvFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf -getSettings :: HandleLike h => HandshakeM h g TH.SettingsS -getSettings = gets fst >>= lift . TH.getInitSetT +getSettingsS :: HandleLike h => HandshakeM h g TH.SettingsS +getSettingsS = gets fst >>= lift . TH.getInitSetT -getSettingsC :: HandleLike h => HandshakeM h g TH.Settings -getSettingsC = gets fst >>= lift . TH.getSettingsT +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 +setSettingsS :: HandleLike h => TH.SettingsS -> HandshakeM h g () +setSettingsS is = gets fst >>= lift . flip TH.setInitSetT is -setSettingsC :: HandleLike h => TH.Settings -> HandshakeM h g () -setSettingsC is = gets fst >>= lift . flip TH.setSettingsT is +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 +type SettingsC = ( + [TH.CipherSuite], + [(TH.CertSecretKey, X509.CertificateChain)], + X509.CertificateStore ) + +getSettingsC :: HandleLike h => HandshakeM h g SettingsC +getSettingsC = do + (css, crts, mcs) <- getSettingsC_ + case mcs of + Just cs -> return (css, crts, cs) + _ -> throwError TH.ALFatal TH.ADInternalError + "Network.PeyoTLS.Base.getSettingsC" + +setSettingsC :: HandleLike h => SettingsC -> HandshakeM h g () +setSettingsC (css, crts, cs) = setSettingsC_ (css, crts, Just cs) + +getAdBuf :: HandleLike h => TH.TlsHandleBase 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.TlsHandleBase h g -> BS.ByteString -> TH.TlsM h g () setAdBuf = TH.setAdBufT getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString @@ -251,7 +292,103 @@ setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs -pushAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g () -pushAdBufH bs = do +pushAdBuf :: HandleLike h => BS.ByteString -> HandshakeM h g () +pushAdBuf bs = do bf <- getAdBufH setAdBufH $ bf `BS.append` bs + +adGet, hlGetRn_ :: (ValidateHandle h, CPRG g) => + (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g -> Int -> + TH.TlsM h g BS.ByteString +adGet = hlGetRn +hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . TH.tlsGet_ rh + . (, undefined) + +hlGetLineRn_, hlGetContentRn_, adGetLine, adGetContent :: + (ValidateHandle h, CPRG g) => + (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g -> TH.TlsM h g BS.ByteString +adGetLine = hlGetLineRn +hlGetLineRn_ rh = ($) <$> checkAppData <*> tGetLine_ rh +adGetContent = hlGetContentRn +hlGetContentRn_ rh = ($) <$> checkAppData <*> tGetContent_ rh + +hsGet :: (HandleLike h, CPRG g) => HandshakeM h g BS.ByteString +hsGet = do + ct <- tlsGetContentType + case ct of + TH.CTHandshake -> do + t <- tlsGet True 1 + len <- tlsGet (t /= "\0") 3 + body <- tlsGet True . either error id $ B.decode len + return $ BS.concat [t, len, body] + _ -> throwError + TH.ALFatal TH.ADUnexpectedMessage $ + "HandshakeBase.readHandshake: not handshake: " ++ show ct + +ccsGet :: (HandleLike h, CPRG g) => HandshakeM h g Word8 +ccsGet = do + ct <- tlsGetContentType + bs <- case ct of + TH.CTCCSpec -> tlsGet True 1 + _ -> throwError TH.ALFatal TH.ADUnexpectedMessage $ + "HandshakeBase.getChangeCipherSpec: " ++ + "not change cipher spec: " ++ show ct + resetSequenceNumber TH.Read + return $ let [w] = BS.unpack bs in w + +hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g () +hsPut = tlsPut TH.CTHandshake + +ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g () +ccsPut w = do + tlsPut TH.CTCCSpec $ BS.pack [w] + resetSequenceNumber TH.Write + +updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g () +updateHash bs = get >>= lift . flip TH.updateHash bs >>= put + +flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g Bool +flushAppData = uncurry (>>) . (pushAdBuf *** return) =<< flushAppData_ + +hlGetRn :: (ValidateHandle h, CPRG g) => (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> + TH.TlsHandleBase h g -> Int -> TH.TlsM h g BS.ByteString +hlGetRn rn t n = do + bf <- getAdBuf t + if BS.length bf >= n + then do let (ret, rest) = BS.splitAt n bf + setAdBuf t rest + return ret + else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf) + +hlGetLineRn :: (ValidateHandle h, CPRG g) => + (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> TH.TlsHandleBase h g -> + TH.TlsM h g BS.ByteString +hlGetLineRn rn t = do + bf <- getAdBuf t + if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf + then do let (ret, rest) = splitOneLine bf + setAdBuf t $ BS.tail rest + return ret + else (bf `BS.append`) `liftM` hlGetLineRn_ rn t + +splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString) +splitOneLine bs = case BSC.span (/= '\r') bs of + (_, "") -> second BS.tail $ BSC.span (/= '\n') bs + (l, ls) -> (l, dropRet ls) + +dropRet :: BS.ByteString -> BS.ByteString +dropRet bs = case BSC.uncons bs of + Just ('\r', bs') -> case BSC.uncons bs' of + Just ('\n', bs'') -> bs'' + _ -> bs' + _ -> bs + +hlGetContentRn :: (ValidateHandle h, CPRG g) => + (TH.TlsHandleBase h g -> TH.TlsM h g ()) -> + TH.TlsHandleBase h g -> TH.TlsM h g BS.ByteString +hlGetContentRn rn t = do + bf <- getAdBuf t + if BS.null bf + then hlGetContentRn_ rn t + else do setAdBuf t "" + return bf 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,65 +1,86 @@ +{-| + +Module : Network.PeyoTLS.Server +Copyright : (c) Yoshikuni Jujo, 2014 +License : BSD3 +Maintainer : PAF01143@nifty.ne.jp +Stability : Experimental + +-} + {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-} module Network.PeyoTLS.Server ( - PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names, + -- * Basic + PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, + -- * Renegotiation + renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, + -- * Cipher Suite CipherSuite(..), KeyEx(..), BulkEnc(..), + -- * Others ValidateHandle(..), CertSecretKey(..) ) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first) import Control.Monad (when, unless, liftM, ap) import "monads-tf" Control.Monad.Error (catchError) -import Data.Maybe (listToMaybe, mapMaybe) +import "monads-tf" Control.Monad.Error.Class (strMsg) import Data.List (find) import Data.Word (Word8) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) +import Numeric (readHex) import "crypto-random" Crypto.Random (CPRG, SystemRNG) +import qualified "monads-tf" Control.Monad.Error as E import qualified Data.ByteString as BS import qualified Data.X509 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.PKCS15 as RSA +import qualified Crypto.Types.PubKey.DH as DH +import qualified Crypto.Types.PubKey.ECC as ECC import qualified Network.PeyoTLS.Base as BASE (names) -import Network.PeyoTLS.Base ( +import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, - SettingsS, getSettings, setSettings, - hlGetRn, hlGetLineRn, hlGetContentRn, + SettingsS, getSettingsS, setSettingsS, + adGet, adGetLine, adGetContent, HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, randomByteString, flushAppData, AlertLevel(..), AlertDesc(..), throwError, debugCipherSuite, ValidateHandle(..), handshakeValidate, validateAlert, - TlsHandle_, CertSecretKey(..), isRsaKey, isEcdsaKey, - readHandshake, writeHandshake, writeHandshakeNH, + TlsHandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey, + readHandshake, writeHandshake, getChangeCipherSpec, putChangeCipherSpec, Handshake(HHelloReq), - ClientHello(..), ServerHello(..), SessionId(..), Extension(..), eRenegoInfo, + ClientHello(..), ServerHello(..), SessionId(..), Extension(..), + isRenegoInfo, emptyRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..), getCipherSuite, setCipherSuite, - checkClientRenego, makeServerRenego, - ServerKeyExchange(..), SecretKey(..), - certificateRequest, ClientCertificateType(..), + checkClRenego, makeSvRenego, + ServerKeyEx(..), SvSignSecretKey(..), + certReq, ClCertType(..), ServerHelloDone(..), - ClientKeyExchange(..), Epms(..), generateKeys, decryptRsa, + ClientKeyEx(..), Epms(..), generateKeys, DigitallySigned(..), ClSignPublicKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash, - DhParam(..), makeEcdsaPubKey, dh3072Modp, secp256r1 ) + DhParam(..), makeEcdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandle_ h g } deriving Show +newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandleBase 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 (TlsHandleS t) = hlPut t - hlGet = hlGetRn rehandshake . tlsHandleS - hlGetLine = hlGetLineRn rehandshake . tlsHandleS - hlGetContent = hlGetContentRn rehandshake . tlsHandleS + hlGet = adGet rehandshake . tlsHandleS + hlGetLine = adGetLine rehandshake . tlsHandleS + hlGetContent = adGetContent rehandshake . tlsHandleS hlDebug (TlsHandleS t) = hlDebug t hlClose (TlsHandleS t) = hlClose t @@ -78,7 +99,7 @@ [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g) open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $ - ((>>) <$> setSettings <*> handshake) (cssv', + ((>>) <$> setSettingsS <*> handshake) (cssv', first rsaKey <$> find (isRsaKey . fst) crts, first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs ) where @@ -91,12 +112,36 @@ iscs EMPTY_RENEGOTIATION_INFO = False iscs _ = True +setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [CipherSuite] -> TlsM h g () +setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do + (_, rcrt, ecrt, mcs) <- getSettingsS + setSettingsS (cssv, rcrt, ecrt, mcs) + +setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + [(CertSecretKey, X509.CertificateChain)] -> TlsM h g () +setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do + (cssv, _, _, mcs) <- getSettingsS + setSettingsS (cssv, + first rsaKey <$> find (isRsaKey . fst) crts, + first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs) + +setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g -> + Maybe X509.CertificateStore -> TlsM h g () +setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do + (cssv, rcrt, ecrt, _) <- getSettingsS + setSettingsS (cssv, rcrt, ecrt, mcs) + renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () -renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >> - flushAppData >>= flip when (handshake =<< getSettings) +renegotiate (TlsHandleS t) = rerunHandshakeM t $ do + writeHandshake HHelloReq + debug "low" ("before flushAppData" :: String) + ne <- flushAppData + debug "low" ("after flushAppData" :: String) + when ne (handshake =<< getSettingsS) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () -rehandshake t = rerunHandshakeM t $ handshake =<< getSettings +rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g () +rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () handshake (cssv, rcrt, ecrt, mcs) = do @@ -127,6 +172,29 @@ writeHandshake =<< finishedHash Server where pre = moduleName ++ ".handshake: " +secp256r1 :: ECC.Curve +secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 + +dh3072Modp :: DH.Params +dh3072Modp = DH.Params p 2 + where [(p, "")] = readHex $ + "ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++ + "29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++ + "ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++ + "e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++ + "ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++ + "c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++ + "83655d23dca3ad961c62f356208552bb9ed529077096966d" ++ + "670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++ + "e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++ + "de2bcbf6955817183995497cea956ae515d2261898fa0510" ++ + "15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++ + "ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++ + "abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++ + "f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++ + "bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++ + "43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff" + clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do @@ -147,12 +215,12 @@ checkRenegoInfo :: HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g () -checkRenegoInfo cscl me = (\n -> maybe n checkClientRenego mcf) . throwError +checkRenegoInfo cscl me = (\n -> maybe n checkClRenego 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 + (True, _) -> Just emptyRenegoInfo + (_, Just e) -> find isRenegoInfo e (_, _) -> Nothing serverHello :: (HandleLike h, CPRG g) => @@ -167,7 +235,7 @@ sr <- randomByteString 32 writeHandshake . ServerHello version sr (SessionId "") cs CompMethodNull - . Just . (: []) =<< makeServerRenego + . Just . (: []) =<< makeSvRenego writeHandshake =<< case (ke, rcc, ecc) of (ECDHE_ECDSA, _, Just c) -> return c (_, Just c, _) -> return c @@ -183,13 +251,14 @@ generateKeys Server rs =<< mkpms epms `catchError` const ((BS.cons vj . BS.cons vn) `liftM` randomByteString 46) where mkpms epms = do - pms <- decryptRsa sk epms + pms <- either (E.throwError . strMsg . show) return =<< + withRandom (\g -> RSA.decryptSafer g 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, +dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey 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) @@ -198,10 +267,10 @@ bl <- withRandom $ generateBlinder sk let pv = B.encode $ calculatePublic dp sv writeHandshake - . ServerKeyEx (B.encode dp) pv ha (signatureAlgorithm sk) - . sign ha bl sk $ BS.concat [cr, sr, B.encode dp, pv] + . ServerKeyEx (B.encode dp) pv ha (sssAlgorithm sk) + . ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] const `liftM` reqAndCert mcs `ap` do - ClientKeyExchange cke <- readHandshake + ClientKeyEx cke <- readHandshake generateKeys Server rs . calculateShared dp sv =<< either (throwError ALFatal ADInternalError . (moduleName ++) . (".dhKeyExchange: " ++)) @@ -210,7 +279,7 @@ reqAndCert :: (ValidateHandle h, CPRG g) => Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey) reqAndCert mcs = do - flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest + flip (maybe $ return ()) mcs $ writeHandshake . certReq [CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] writeHandshake SHDone flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do 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 @@ -16,7 +16,7 @@ getServerFinished, setServerFinished, SettingsS, Settings, - CertSecretKey(..), + CertSecretKey(..), isRsaKey, isEcdsaKey, ) where import Control.Applicative ((<$>)) @@ -30,7 +30,7 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) +import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 @@ -85,14 +85,6 @@ 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, 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 @@ -1,16 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.PeyoTLS.Types ( Extension(..), +module Network.PeyoTLS.Types ( Handshake(..), HandshakeItem(..), ClientHello(..), ServerHello(..), SessionId(..), CipherSuite(..), KeyEx(..), BulkEnc(..), - CompMethod(..), - ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), - CertReq(..), certificateRequest, ClientCertificateType(..), + CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo, + ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..), + CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..), - ServerHelloDone(..), ClientKeyExchange(..), Epms(..), - DigitallySigned(..), Finished(..) ) where + ServerHelloDone(..), ClientKeyEx(..), Epms(..), + DigitallySigned(..), Finished(..), + ChangeCipherSpec(..), ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless) @@ -28,15 +29,15 @@ CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..) ) import Network.PeyoTLS.Certificate ( - CertReq(..), certificateRequest, ClientCertificateType(..), - ClientKeyExchange(..), DigitallySigned(..) ) + CertReq(..), certReq, ClCertType(..), + ClientKeyEx(..), DigitallySigned(..) ) data Handshake = HHelloReq | HClientHello ClientHello | HServerHello ServerHello | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString | HCertificateReq CertReq | HServerHelloDone - | HCertVerify DigitallySigned | HClientKeyEx ClientKeyExchange + | HCertVerify DigitallySigned | HClientKeyEx ClientKeyEx | HFinished BS.ByteString | HRaw Type BS.ByteString deriving Show @@ -103,7 +104,7 @@ fromHandshake _ = Nothing toHandshake = HCertificate -data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString +data ServerKeyEx = ServerKeyEx BS.ByteString BS.ByteString HashAlg SignAlg BS.ByteString deriving Show data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber @@ -112,7 +113,7 @@ data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point HashAlg SignAlg BS.ByteString deriving Show -instance HandshakeItem ServerKeyExchange where +instance HandshakeItem ServerKeyEx where fromHandshake = undefined toHandshake = HServerKeyEx . B.encode @@ -128,7 +129,7 @@ either (const Nothing) Just $ B.decode ske fromHandshake _ = Nothing -instance B.Bytable ServerKeyExchange where +instance B.Bytable ServerKeyEx where decode = undefined encode (ServerKeyEx ps pv ha sa sn) = BS.concat [ ps, pv, B.encode ha, B.encode sa, @@ -178,7 +179,7 @@ fromHandshake _ = Nothing toHandshake = HCertVerify -instance HandshakeItem ClientKeyExchange where +instance HandshakeItem ClientKeyEx where fromHandshake (HClientKeyEx cke) = Just cke fromHandshake _ = Nothing toHandshake = HClientKeyEx @@ -190,13 +191,13 @@ fromHandshake _ = Nothing toHandshake = HClientKeyEx . epmsToCke -ckeToEpms :: ClientKeyExchange -> Maybe Epms -ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of +ckeToEpms :: ClientKeyEx -> Maybe Epms +ckeToEpms (ClientKeyEx cke) = case B.runBytableM (B.take =<< B.take 2) cke of Right (e, "") -> Just $ Epms e _ -> Nothing -epmsToCke :: Epms -> ClientKeyExchange -epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms +epmsToCke :: Epms -> ClientKeyEx +epmsToCke (Epms epms) = ClientKeyEx $ B.addLen (undefined :: Word16) epms data Finished = Finished BS.ByteString deriving (Show, Eq) @@ -238,3 +239,20 @@ encode TClientKeyEx = BS.pack [16] encode TFinished = BS.pack [20] encode (TRaw w) = BS.pack [w] + +data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show + +instance B.Bytable ChangeCipherSpec where + decode bs = case BS.unpack bs of + [1] -> Right ChangeCipherSpec + [w] -> Right $ ChangeCipherSpecRaw w + _ -> Left "HandshakeBase: ChangeCipherSpec.decode" + encode ChangeCipherSpec = BS.pack [1] + encode (ChangeCipherSpecRaw w) = BS.pack [w] + +isRenegoInfo :: Extension -> Bool +isRenegoInfo (ERenegoInfo _) = True +isRenegoInfo _ = False + +emptyRenegoInfo :: Extension +emptyRenegoInfo = ERenegoInfo "" diff --git a/test/testReneg.hs b/test/testReneg.hs --- a/test/testReneg.hs +++ b/test/testReneg.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