peyotls 0.0.0.23 → 0.0.0.24
raw patch · 17 files changed
+823/−864 lines, 17 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Network.PeyoTLS.Client: getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]
+ Network.PeyoTLS.Server: getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]
Files
- examples/clcertClient.hs +2/−1
- examples/clcertEcdsaClient.hs +2/−1
- examples/clcertServer.hs +1/−0
- examples/eccClient.hs +2/−1
- examples/simpleClient.hs +2/−1
- peyotls.cabal +4/−3
- src/Network/PeyoTLS/Base.hs +57/−57
- src/Network/PeyoTLS/Client.hs +39/−34
- src/Network/PeyoTLS/Crypto.hs +8/−5
- src/Network/PeyoTLS/Ecdsa.hs +51/−60
- src/Network/PeyoTLS/Extension.hs +20/−0
- src/Network/PeyoTLS/Handle.hs +342/−263
- src/Network/PeyoTLS/Monad.hs +85/−54
- src/Network/PeyoTLS/Run.hs +140/−340
- src/Network/PeyoTLS/Server.hs +45/−39
- src/Network/PeyoTLS/State.hs +14/−4
- src/Network/PeyoTLS/Types.hs +9/−1
examples/clcertClient.hs view
@@ -22,7 +22,8 @@ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca- unless ("localhost" `elem` names p) $+ nms <- getNames p+ unless ("localhost" `elem` nms) $ error "certificate name mismatch" hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n"
examples/clcertEcdsaClient.hs view
@@ -24,7 +24,8 @@ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(ek, ec), (rk, rc)] ca- unless ("localhost" `elem` names p) $+ nms <- getNames p+ unless ("localhost" `elem` nms) $ error "certificate name mismatch" hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n"
examples/clcertServer.hs view
@@ -28,6 +28,7 @@ liftIO . forkIO . (`run` g) $ do p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)] $ Just ca+ getNames p >>= liftIO . print doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn hlPut p $ BS.concat [ "HTTP/1.1 200 OK\r\n",
examples/eccClient.hs view
@@ -31,7 +31,8 @@ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do p <- open h cipherSuites [] ca- unless ("localhost" `elem` names p) $+ nms <- getNames p+ unless ("localhost" `elem` nms p) $ error "certificate name mismatch" hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n"
examples/simpleClient.hs view
@@ -20,7 +20,8 @@ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG (`run` g) $ do p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca- unless ("localhost" `elem` names p) $+ nms <- getNames p+ unless ("localhost" `elem` nms) $ error "certificate name mismatch" hlPut p "GET / HTTP/1.1 \r\n" hlPut p "Host: localhost\r\n\r\n"
peyotls.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: peyotls-version: 0.0.0.23+version: 0.0.0.24 stability: Experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -148,7 +148,8 @@ > g <- cprgCreate <$> createEntropyPool :: IO SystemRNG > (`run` g) $ do > p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca- > unless ("localhost" `elem` names p) $+ > nms <- getNames p+ > unless ("localhost" `elem` nms) $ > error "certificate name mismatch" > hlPut p "GET / HTTP/1.1 \r\n" > hlPut p "Host: localhost\r\n\r\n"@@ -282,7 +283,7 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/peyotls.git- tag: peyotls-0.0.0.23+ tag: peyotls-0.0.0.24 library hs-source-dirs: src
src/Network/PeyoTLS/Base.hs view
@@ -2,17 +2,17 @@ module Network.PeyoTLS.Base ( PeyotlsM, TlsM, run, SettingsS,- adGet, adGetLine, adGetContent,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM, getSettingsC, setSettingsC, getSettingsS, setSettingsS,- withRandom, randomByteString, flushAppData,- AlertLevel(..), AlertDesc(..), throwError,+ withRandom, flushAd,+ AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, debug, ValidateHandle(..), handshakeValidate, validateAlert,- TlsHandleBase, names,+ TlsHandleBase, names, getNames, CertSecretKey(..), isRsaKey, isEcdsaKey, readHandshake, writeHandshake,- getChangeCipherSpec, putChangeCipherSpec,+ ChangeCipherSpec(..), Handshake(HHelloReq), ClientHello(..), ServerHello(..), SessionId(..), Extension(..), isRenegoInfo, emptyRenegoInfo,@@ -24,12 +24,12 @@ SvSignSecretKey(..), SvSignPublicKey(..), CertReq(..), certReq, ClCertType(..), ServerHelloDone(..),- ClientKeyEx(..), Epms(..), generateKeys,+ ClientKeyEx(..), Epms(..), makeKeys, DigitallySigned(..), ClSignPublicKey(..), ClSignSecretKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash,- DhParam(..), makeEcdsaPubKey ) where+ DhParam(..), ecdsaPubKey ) where import Control.Arrow (first) import Control.Monad (unless, liftM, ap)@@ -68,61 +68,61 @@ CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..), ServerHelloDone(..), ClientKeyEx(..), Epms(..), DigitallySigned(..), ChangeCipherSpec(..), Finished(..) )-import qualified Network.PeyoTLS.Run as RUN (finishedHash)+import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run (- TlsM, run, TlsHandleBase(..), names,- hsGet, hsPut, updateHash, ccsGet, ccsPut,- adGet, adGetLine, adGetContent,+ TlsM, run, TlsHandleBase(..), getNames,+ chGet, hsPut, updateHash, ccsPut,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM,- withRandom, randomByteString, flushAppData,+ withRandom, flushAd, SettingsS, getSettingsS, setSettingsS, getSettingsC, setSettingsC, getCipherSuite, setCipherSuite, CertSecretKey(..), isRsaKey, isEcdsaKey, getClFinished, getSvFinished, setClFinished, setSvFinished,- RW(..), flushCipherSuite, generateKeys,+ RW(..), flushCipherSuite, makeKeys, Side(..), handshakeHash, -- finishedHash, ValidateHandle(..), handshakeValidate, validateAlert,- AlertLevel(..), AlertDesc(..), debugCipherSuite, throwError )-import Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey)+ AlertLevel(..), AlertDesc(..), debugCipherSuite, throw )+import Network.PeyoTLS.Ecdsa (blSign, makeKs, ecdsaPubKey) -moduleName :: String-moduleName = "Network.PeyoTLS.Base"+modNm :: String+modNm = "Network.PeyoTLS.Base" type PeyotlsM = TlsM Handle SystemRNG debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g () debug p x = do- h <- gets $ tlsHandle . fst- lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x+ t <- gets fst+ lift . RUN.debug t p . BSC.pack . (++ "\n") $ show x readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi readHandshake = do- 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+ ch <- chGet+ case ch of+ Left 1 -> case fromHandshake HCCSpec of+ Just i -> return i+ _ -> throw ALFatal ADUnexMsg $+ modNm ++ ".readHandshake: " ++ show HCCSpec+ Right bs -> case B.decode bs of+ Right HHelloReq -> readHandshake+ Right hs -> case fromHandshake hs of+ Just i -> updateHash bs >> return i+ _ -> throw ALFatal ADUnexMsg $+ modNm ++ ".readHandshake: " ++ show hs+ Left em -> throw ALFatal ADInternalError $+ modNm ++ ".readHandshake: " ++ em+ _ -> throw ALFatal ADUnexMsg $ modNm ++ ".readHandshake: uk ccs" 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) => HandshakeM h g ()-getChangeCipherSpec = do- 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) => HandshakeM h g ()-putChangeCipherSpec = ccsPut . (\[w] -> w) . BS.unpack $ B.encode ChangeCipherSpec+writeHandshake hi = do+ case hs of+ HHelloReq -> hsPut bs+ HCCSpec -> ccsPut . (\[w] -> w) $ BS.unpack bs+ _ -> hsPut bs >> updateHash bs+ where+ hs = toHandshake hi+ bs = B.encode hs finishedHash :: (HandleLike h, CPRG g) => Side -> HandshakeM h g Finished finishedHash s = Finished `liftM` do@@ -133,16 +133,16 @@ 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"+ unless ok . throw ALFatal ADHsFailure $+ modNm ++ ".checkClRenego: renego info is not match"+checkClRenego _ = throw ALFatal ADInternalError $+ modNm ++ ".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"+ unless ok . throw ALFatal ADHsFailure $+ modNm ++ ".checkSvRenego: renego info is not match"+checkSvRenego _ = throw ALFatal ADInternalError $+ modNm ++ ".checkSvRenego: not renego info" makeClRenego, makeSvRenego :: HandleLike h => HandshakeM h g Extension makeClRenego = ERenegoInfo `liftM` getClFinished@@ -200,7 +200,7 @@ where (hs, oid0) = case ha of Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256)- _ -> error $ moduleName ++ ": RSA.PublicKey.ssVerify"+ _ -> error $ modNm ++ ": 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,@@ -209,14 +209,14 @@ ASN1.OctetString o, ASN1.End ASN1.Sequence ] -> (o, i) em -> error $- moduleName ++ ": RSA.PublicKey.ssVerify" ++ show em+ modNm ++ ": RSA.PublicKey.ssVerify" ++ show em instance SvSignPublicKey ECDSA.PublicKey where 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"+ ssVerify _ _ = error $ modNm ++ ": ECDSA.PublicKey.verify" class SvSignSecretKey sk where type Blinder sk@@ -233,7 +233,7 @@ where (hs, oid) = first ($ m) $ case ha of Sha1 -> (SHA1.hash, sha1); Sha256 -> (SHA256.hash, sha256)- _ -> error $ moduleName ++ ": RSA.PrivateKey.ssSign"+ _ -> error $ modNm ++ ": RSA.PrivateKey.ssSign" b = ASN1.encodeASN1' ASN1.DER [ASN1.Start ASN1.Sequence, ASN1.Start ASN1.Sequence, oid, ASN1.Null, ASN1.End ASN1.Sequence,@@ -247,11 +247,11 @@ 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+ ssSign sk ha bl m = B.encode $ blSign sk hs (makeKs (hs, bls) q x m) bl m where (hs, bls) = case ha of Sha1 -> (SHA1.hash, 64); Sha256 -> (SHA256.hash, 64)- _ -> error $ moduleName ++ ": ECDSA.PrivateKey.ssSign"+ _ -> error $ modNm ++ ": ECDSA.PrivateKey.ssSign" q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk @@ -277,7 +277,7 @@ instance ClSignSecretKey ECDSA.PrivateKey where cssAlgorithm _ = (Sha256, Ecdsa)- csSign sk m = enc $ blindSign 0 id sk (makeKs (SHA256.hash, 64) q x m) m+ csSign sk m = enc $ blSign sk id (makeKs (SHA256.hash, 64) q x m) 0 m where q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk x = ECDSA.private_d sk
src/Network/PeyoTLS/Client.hs view
@@ -12,7 +12,7 @@ module Network.PeyoTLS.Client ( -- * Basic- PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names,+ PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite@@ -27,7 +27,7 @@ import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)-import "crypto-random" Crypto.Random (CPRG, SystemRNG)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) import qualified Data.ByteString as BS import qualified Data.X509 as X509@@ -40,18 +40,17 @@ 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 qualified Network.PeyoTLS.Base as BASE (names, getNames) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, getSettingsC, setSettingsC,- adGet, adGetLine, adGetContent,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM,- withRandom, randomByteString, flushAppData,- AlertLevel(..), AlertDesc(..), throwError,+ withRandom, flushAd,+ AlertLevel(..), AlertDesc(..), throw, ValidateHandle(..), handshakeValidate, validateAlert, TlsHandleBase, CertSecretKey(..),- readHandshake, writeHandshake,- getChangeCipherSpec, putChangeCipherSpec,+ readHandshake, writeHandshake, ChangeCipherSpec(..), ClientHello(..), ServerHello(..), SessionId(..), isRenegoInfo, CipherSuite(..), KeyEx(..), BulkEnc(..), CompMethod(..), HashAlg(..), SignAlg(..),@@ -60,10 +59,10 @@ ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..), CertReq(..), ClCertType(..), ServerHelloDone(..),- ClientKeyEx(..), Epms(..), generateKeys, -- encryptRsa,+ ClientKeyEx(..), Epms(..), makeKeys, DigitallySigned(..), ClSignSecretKey(..), handshakeHash, Side(..), RW(..), finishedHash, flushCipherSuite,- DhParam(..), makeEcdsaPubKey )+ DhParam(..), ecdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG @@ -72,19 +71,24 @@ 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+ hlPut = adPut . tlsHandleC hlGet = adGet rehandshake . tlsHandleC hlGetLine = adGetLine rehandshake . tlsHandleC hlGetContent = adGetContent rehandshake . tlsHandleC- hlDebug (TlsHandleC t) = hlDebug t- hlClose (TlsHandleC t) = hlClose t+ hlDebug = adDebug . tlsHandleC+ hlClose = adClose . tlsHandleC moduleName :: String moduleName = "Network.PeyoTLS.Client" +{-# DEPRECATED names "Use getNames instead" #-}+ names :: TlsHandle h g -> [String] names = BASE.names . tlsHandleC +getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]+getNames = BASE.getNames . tlsHandleC+ open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> TlsM h g (TlsHandle h g)@@ -95,8 +99,7 @@ renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do (cscl, crts, ca) <- getSettingsC- clientHello cscl >>= \cr ->- flushAppData >>= flip when (handshake crts ca cr)+ clientHello cscl >>= \cr -> flushAd >>= flip when (handshake crts ca cr) setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g -> [CipherSuite] -> TlsM h g ()@@ -124,7 +127,7 @@ clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> HandshakeM h g BS.ByteString clientHello cscl = do- cr <- randomByteString 32+ cr <- withRandom $ cprgGenerate 32 ((>>) <$> writeHandshake <*> debug "low") . ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull] . Just . (: []) =<< makeClRenego@@ -140,7 +143,7 @@ DHE_RSA -> dheHandshake (undefined :: DH.Params) ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve)- _ -> \_ _ _ -> throwError ALFatal ADHsFailure $+ _ -> \_ _ _ -> throw ALFatal ADHsFailure $ moduleName ++ ".handshake: not implemented" serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx)@@ -148,15 +151,15 @@ ServerHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake case v of (3, 3) -> return ()- _ -> throwError ALFatal ADProtocolVersion $+ _ -> throw ALFatal ADProtocolVersion $ moduleName ++ ".serverHello: only TLS 1.2" case cm of CompMethodNull -> return ()- _ -> throwError ALFatal ADHsFailure $+ _ -> throw ALFatal ADHsFailure $ moduleName ++ ".serverHello: only compression method null" case find isRenegoInfo $ fromMaybe [] e of Just ri -> checkSvRenego ri- _ -> throwError ALFatal ADInsufficientSecurity $+ _ -> throw ALFatal ADInsufficientSecurity $ moduleName ++ ".serverHello: require secure renegotiation" setCipherSuite cs return (sr, ke)@@ -167,15 +170,15 @@ rsaHandshake rs crts ca = do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc- unless (null vr) . throwError ALFatal (validateAlert vr) $+ unless (null vr) . throw 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 $+ _ -> throw ALFatal ADIllegalParameter $ moduleName ++ ".rsaHandshake: require RSA public key" crt <- clientCertificate crts- pms <- ("\x03\x03" `BS.append`) `liftM` randomByteString 46- generateKeys Client rs pms+ pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46)+ makeKeys Client rs pms writeHandshake . Epms =<< encryptRsa pk pms finishHandshake crt @@ -192,12 +195,12 @@ dheHandshake t rs crts ca = do cc@(X509.CertificateChain (c : _)) <- readHandshake vr <- handshakeValidate ca cc- unless (null vr) . throwError ALFatal (validateAlert vr) $+ unless (null vr) . throw ALFatal (validateAlert vr) $ moduleName ++ ".succeed: validate failure" 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 $+ X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts+ _ -> throw ALFatal ADHsFailure $ moduleName ++ ".dheHandshake: not implemented" succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk,@@ -207,13 +210,13 @@ succeed t pk rs@(cr, sr) crts = do (ps, pv, ha, sa, sn) <- serverKeyExchange let _ = ps `asTypeOf` t- unless (sa == sspAlgorithm pk) . throwError ALFatal ADHsFailure $+ unless (sa == sspAlgorithm pk) . throw ALFatal ADHsFailure $ pre ++ "sign algorithm unmatch" unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .- throwError ALFatal ADDecryptError $ pre ++ "verify failure"+ throw ALFatal ADDecryptError $ pre ++ "verify failure" crt <- clientCertificate crts sv <- withRandom $ generateSecret ps- generateKeys Client rs $ calculateShared ps sv pv+ makeKeys Client rs $ calculateShared ps sv pv writeHandshake . ClientKeyEx . B.encode $ calculatePublic ps sv finishHandshake crt where pre = moduleName ++ ".succeed: "@@ -242,7 +245,7 @@ case find (isMatchedCert cct a dn) crts of Just c -> (>>) <$> writeHandshake . snd <*> return . Just $ c- _ -> throwError ALFatal ADUnknownCa $ moduleName +++ _ -> throw ALFatal ADUnknownCa $ moduleName ++ ".clientCertificate: no certificate" isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] ->@@ -269,9 +272,11 @@ Just (EcdsaKey sk) -> writeHandshake $ DigitallySigned (cssAlgorithm sk) $ csSign sk hs _ -> return ()- putChangeCipherSpec >> flushCipherSuite Write+ writeHandshake ChangeCipherSpec+ flushCipherSuite Write writeHandshake =<< finishedHash Client- getChangeCipherSpec >> flushCipherSuite Read+ ChangeCipherSpec <- readHandshake+ flushCipherSuite Read (==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless- (throwError ALFatal ADDecryptError $+ (throw ALFatal ADDecryptError $ moduleName ++ ".finishHandshake: finished hash failure")
src/Network/PeyoTLS/Crypto.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-} module Network.PeyoTLS.Crypto (- makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where+ makeKeys, encrypt, decrypt, hashSha1, hashSha256,+ Side(..), finishedHash) where import Prelude hiding (splitAt, take) @@ -84,10 +85,12 @@ calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m -finishedHash :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString-finishedHash c ms hash = take 12 . prf ms . (`BS.append` hash) $ if c- then "client finished"- else "server finished"+data Side = Server | Client deriving (Show, Eq)++finishedHash :: Side -> BS.ByteString -> BS.ByteString -> BS.ByteString+finishedHash s ms hash = take 12 . prf ms . (`BS.append` hash) $ case s of+ Client -> "client finished"+ Server -> "server finished" myLast :: String -> BS.ByteString -> Word8 myLast msg "" = error msg
src/Network/PeyoTLS/Ecdsa.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.PeyoTLS.Ecdsa (blindSign, makeKs, makeEcdsaPubKey) where+module Network.PeyoTLS.Ecdsa (blSign, makeKs, ecdsaPubKey) where import Control.Applicative ((<$>), (<*>)) import Data.Maybe (mapMaybe)@@ -9,33 +9,22 @@ import Crypto.Number.ModArithmetic (inverse) 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 Codec.Bytable.BigEndian as B import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Data.ASN1.Types as ASN1-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,- ASN1.IntVal r, ASN1.IntVal s, ASN1.End ASN1.Sequence ]- decode bs = case ASN1.decodeASN1' ASN1.DER bs of- Right [ASN1.Start ASN1.Sequence, ASN1.IntVal r, ASN1.IntVal s,- ASN1.End ASN1.Sequence] -> Right $ ECDSA.Signature r s- Right _ -> Left "KeyExchange.decodeSignature"- Left err -> Left $ "KeyExchange.decodeSignature: " ++ show err- type Hash = BS.ByteString -> BS.ByteString -blindSign :: Integer -> Hash -> ECDSA.PrivateKey -> [Integer] ->+blSign :: ECDSA.PrivateKey -> Hash -> [Integer] -> Integer -> BS.ByteString -> ECDSA.Signature-blindSign bl hs (ECDSA.PrivateKey crv d) ks m = head $ bs `mapMaybe` ks+blSign (ECDSA.PrivateKey crv d) hs ks bl m = head $ bs `mapMaybe` ks where bs k = do r <- case bPointMul bl crv k g of@@ -45,24 +34,58 @@ ki <- inverse k n case ki * (z + r * d) `mod` n of 0 -> Nothing- s -> return $ ECDSA.Signature r s+ s -> Just $ ECDSA.Signature r s ECC.CurveCommon _ _ g n _ = ECC.common_curve crv- Right e = B.decode $ hs m- dl = qlen e - qlen n z = if dl > 0 then e `shiftR` dl else e+ e = either error id . B.decode $ hs m+ dl = qlen e - qlen n bPointMul :: Integer -> ECC.Curve -> Integer -> ECC.Point -> ECC.Point bPointMul bl c@(ECC.CurveFP (ECC.CurvePrime _ cc)) k p = ECC.pointMul c (bl * ECC.ecc_n cc + k) p-bPointMul _ _ _ _ = error "Ecdsa.bPointMul: not implemented"+bPointMul _ _ _ _ = error $ moduleName ++ ".bPointMul: not implemented" +ecdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey+ecdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ pnt xy+ where pnt 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 fmt"++instance B.Bytable ECDSA.Signature where+ encode (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [+ ASN1.Start ASN1.Sequence,+ ASN1.IntVal r, ASN1.IntVal s, ASN1.End ASN1.Sequence ]+ decode bs = case ASN1.decodeASN1' ASN1.DER bs of+ Right [ASN1.Start ASN1.Sequence,+ ASN1.IntVal r, ASN1.IntVal s, ASN1.End ASN1.Sequence] ->+ Right $ ECDSA.Signature r s+ Right _ -> Left $ moduleName ++ ": ECDSA.Signature.decode"+ Left err -> Left $+ moduleName ++ ": ECDSA.Signature.decode: " ++ show err+ -- RFC 6979 -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+makeKs :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> [Integer]+makeKs hb@(hs, _) q x = filter ((&&) <$> (> 0) <*> (< q))+ . uncurry (createKs hb q) . initializeKV hb q x . hs +createKs :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString -> [Integer]+createKs hb@(hs, bls) q k v = kk : createKs hb q k' v''+ where+ (t, v') = createT hb q k v ""+ kk = bits2int q t+ k' = hmac hs bls k $ v' `BS.append` "\x00"+ v'' = hmac hs bls k' v'++createT :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString ->+ BS.ByteString -> (BS.ByteString, BS.ByteString)+createT hb@(hs, bls) q k v t+ | blen t < qlen q = createT hb q k v' $ t `BS.append` v'+ | otherwise = (t, v)+ where v' = hmac hs bls k v+ initializeKV :: (Hash, Int) -> Integer -> Integer -> BS.ByteString -> (BS.ByteString, BS.ByteString) initializeKV (hs, bls) q x h = (k2, v2)@@ -76,22 +99,6 @@ BS.concat [v1, "\x01", int2octets q x, bits2octets q h] v2 = hmac hs bls k2 v1 -createKs :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString -> [Integer]-createKs hsbl@(hs, bls) q k v = kk : createKs hsbl q k' v''- where- (t, v') = createT hsbl q k v ""- kk = bits2int q t- k' = hmac hs bls k $ v' `BS.append` "\x00"- v'' = hmac hs bls k' v'--createT :: (Hash, Int) -> Integer -> BS.ByteString -> BS.ByteString ->- BS.ByteString -> (BS.ByteString, BS.ByteString)-createT hsbl@(hs, bls) q k v t- | blen t < qlen q = createT hsbl q k v' $ t `BS.append` v'- | otherwise = (t, v)- where- v' = hmac hs bls k v- hmac :: (BS.ByteString -> BS.ByteString) -> Int -> BS.ByteString -> BS.ByteString -> BS.ByteString hmac hs bls sk =@@ -116,29 +123,13 @@ bits2int q bs | bl > ql = i `shiftR` (bl - ql) | otherwise = i- where- ql = qlen q- bl = blen bs- i = either error id $ B.decode bs+ where ql = qlen q; bl = blen bs; i = either error id $ B.decode bs int2octets :: Integer -> Integer -> BS.ByteString int2octets q i | bl <= rl = BS.replicate (rl - bl) 0 `BS.append` bs- | otherwise = error "Functions.int2octets: too large integer"- where- rl = rlen q `div` 8- bs = B.encode i- bl = BS.length bs+ | otherwise = error $ moduleName ++ ".int2octets: too large integer"+ where rl = rlen q `div` 8; bs = B.encode i; bl = BS.length bs 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"
src/Network/PeyoTLS/Extension.hs view
@@ -134,6 +134,17 @@ w -> ECTRaw w instance B.Bytable ECC.CurveName where+ encode ECC.SEC_t163k1 = B.encode (1 :: Word16)+ encode ECC.SEC_t163r1 = B.encode (2 :: Word16)+ encode ECC.SEC_t163r2 = B.encode (3 :: Word16)+ encode ECC.SEC_t193r1 = B.encode (4 :: Word16)+ encode ECC.SEC_t193r2 = B.encode (5 :: Word16)+ encode ECC.SEC_t233k1 = B.encode (6 :: Word16)+ encode ECC.SEC_t233r1 = B.encode (7 :: Word16)+ encode ECC.SEC_t409k1 = B.encode (11 :: Word16)+ encode ECC.SEC_t409r1 = B.encode (12 :: Word16)+ encode ECC.SEC_t571k1 = B.encode (13 :: Word16)+ encode ECC.SEC_t571r1 = B.encode (14 :: Word16) encode ECC.SEC_p256r1 = B.encode (23 :: Word16) encode ECC.SEC_p384r1 = B.encode (24 :: Word16) encode ECC.SEC_p521r1 = B.encode (25 :: Word16)@@ -141,6 +152,15 @@ decode bs = case BS.unpack bs of [w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of (1 :: Word16) -> Right ECC.SEC_t163k1+ (2 :: Word16) -> Right ECC.SEC_t163r1+ (3 :: Word16) -> Right ECC.SEC_t163r2+ (4 :: Word16) -> Right ECC.SEC_t193r1+ (5 :: Word16) -> Right ECC.SEC_t193r2+ (6 :: Word16) -> Right ECC.SEC_t233k1+ (7 :: Word16) -> Right ECC.SEC_t233r1+ (11 :: Word16) -> Right ECC.SEC_t409k1+ (12 :: Word16) -> Right ECC.SEC_t409r1+ (13 :: Word16) -> Right ECC.SEC_t571k1 (14 :: Word16) -> Right ECC.SEC_t571r1 (23 :: Word16) -> Right ECC.SEC_p256r1 (24 :: Word16) -> Right ECC.SEC_p384r1
src/Network/PeyoTLS/Handle.hs view
@@ -1,372 +1,399 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}--module Network.PeyoTLS.Handle (- TlsM, Alert(..), AlertLevel(..), AlertDesc(..),- run, withRandom, randomByteString,- TlsHandleBase(..), RW(..), Side(..), ContentType(..), CipherSuite(..),- newHandle, getContentType, tlsGet, tlsPut, generateKeys,- debugCipherSuite,- getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt,- setKeys,- handshakeHash, finishedHash,- hlPut_, hlDebug_, hlClose_, tGetLine, tGetLine_, tGetContent,- getClientFinishedT, setClientFinishedT,- getServerFinishedT, setServerFinishedT,-- Settings,- getSettingsT, setSettingsT,- getInitSetT, setInitSetT,- SettingsS,-- resetSequenceNumber,- tlsGet_,- flushAppData,-- getAdBufT, setAdBufT,- CertSecretKey(..), isRsaKey, isEcdsaKey,-- updateHash,- ) where+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-} -import Prelude hiding (read)+module Network.PeyoTLS.Handle ( debug,+ M.TlsM, run, M.withRandom,+ TlsHandleBase(names), M.CipherSuite,+ newHandle, chGet, ccsPut, hsPut,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose,+ flushAd, getBuf, setBuf,+ getCipherSuite, setCipherSuite,+ M.SettingsC, getSettingsC, setSettingsC,+ M.SettingsS, getSettingsS, setSettingsS,+ getClFinished, getSvFinished, setClFinished, setSvFinished,+ makeKeys, setKeys,+ getNames, setNames,+ C.Side(..), finishedHash,+ M.RW(..), flushCipherSuite,+ ValidateHandle(..), tValidate,+ M.CertSecretKey(..), M.isRsaKey, M.isEcdsaKey,+ M.Alert(..), M.AlertLevel(..), M.AlertDesc(..), debugCipherSuite ) where import Control.Arrow (second)-import Control.Monad (liftM, when, unless)-import "monads-tf" Control.Monad.State (get, put, lift)-import "monads-tf" Control.Monad.Error (throwError, catchError)-import "monads-tf" Control.Monad.Error.Class (strMsg)-import Data.Word (Word16, Word64)+import Control.Monad (when, unless, liftM)+import "monads-tf" Control.Monad.State (lift, get, put)+import "monads-tf" Control.Monad.Error (catchError, throwError)+import Data.Word (Word8, Word16, Word64) import Data.HandleLike (HandleLike(..))+import System.IO (Handle) 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 Codec.Bytable.BigEndian as B-import qualified Crypto.Hash.SHA256 as SHA256 -import Network.PeyoTLS.Monad (- TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug,- withRandom, randomByteString,- getBuf, setBuf, getWBuf, setWBuf,- getAdBuf, setAdBuf,- getReadSn, getWriteSn, succReadSn, succWriteSn,- resetReadSn, resetWriteSn,- getCipherSuiteSt, setCipherSuiteSt,- flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys,- Alert(..), AlertLevel(..), AlertDesc(..),- ContentType(..), CipherSuite(..), BulkEnc(..),- PartnerId, newPartnerId, Keys(..),- getClientFinished, setClientFinished,- getServerFinished, setServerFinished,- Settings, getSettings, setSettings,- SettingsS,- getInitSet, setInitSet,- CertSecretKey(..), isRsaKey, isEcdsaKey,- )-import qualified Network.PeyoTLS.Crypto as CT (- makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash )+import qualified Network.PeyoTLS.Monad as M (+ TlsM, evalTlsM, initState, withRandom,+ Alert(..), AlertLevel(..), AlertDesc(..),+ tGet, tPut, tClose, tDebug,+ PartnerId, newPartnerId, ContentType(..),+ getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,+ getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn,+ getClFinished, getSvFinished, setClFinished, setSvFinished,+ getNames, setNames,+ CipherSuite(..), BulkEnc(..), CertSecretKey(..), isRsaKey, isEcdsaKey,+ SettingsC, getSettingsC, setSettingsC,+ SettingsS, getSettingsS, setSettingsS,+ RW(..), getCipherSuite, setCipherSuite, flushCipherSuite,+ Keys(..), getKeys, setKeys )+import qualified Network.PeyoTLS.Crypto as C (+ makeKeys, encrypt, decrypt, hashSha1, hashSha256,+ Side(..), finishedHash ) +class HandleLike h => ValidateHandle h where+ validate :: h -> X509.CertificateStore -> X509.CertificateChain ->+ HandleMonad h [X509.FailedReason]++tValidate :: ValidateHandle h =>+ TlsHandleBase h g -> X509.CertificateStore -> X509.CertificateChain ->+ M.TlsM h g [X509.FailedReason]+tValidate t cs cc = lift . lift $ validate (tlsHandle t) cs cc++instance ValidateHandle Handle where+ validate _ cs cc =+ X509.validate X509.HashSHA256 X509.defaultHooks ch cs ca ("", "") cc+ where+ ch = X509.defaultChecks { X509.checkFQHN = False }+ ca = X509.ValidationCache+ (\_ _ _ -> return X509.ValidationCacheUnknown)+ (\_ _ _ -> return ())+ data TlsHandleBase h g = TlsHandleBase {- clientId :: PartnerId,+ partnerId :: M.PartnerId, tlsHandle :: h, names :: [String] } deriving Show -type HandleHash h g = (TlsHandleBase h g, SHA256.Ctx)--data Side = Server | Client deriving (Show, Eq)--run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a+run :: HandleLike h => M.TlsM h g a -> g -> HandleMonad h a run m g = do- ret <- (`evalTlsM` initState g) $ m `catchError` \a -> throwError a+ ret <- (`M.evalTlsM` M.initState g) $ m `catchError` \a -> throwError a case ret of Right r -> return r Left a -> error $ show a -newHandle :: HandleLike h => h -> TlsM h g (TlsHandleBase h g)+newHandle :: HandleLike h => h -> M.TlsM h g (TlsHandleBase h g) newHandle h = do s <- get- let (i, s') = newPartnerId s+ let (i, s') = M.newPartnerId s put s' return TlsHandleBase {- clientId = i, tlsHandle = h, names = [] }+ partnerId = i, tlsHandle = h, names = [] } -getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g ContentType+getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g M.ContentType getContentType t = do- ct <- fst `liftM` getBuf (clientId t)- (\gt -> case ct of CTNull -> gt; _ -> return ct) $ do- (ct', bf) <- getWholeWithCt t- setBuf (clientId t) (ct', bf)- return ct'+ (ct, bs) <- M.getRBuf (partnerId t)+ (\gt -> case (ct, bs) of (M.CTNull, _) -> gt; (_, "") -> gt; _ -> return ct) $+ do (ct', bf) <- getWholeWithCt t+ M.setRBuf (partnerId t) (ct', bf)+ return ct' -flushAppData :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> TlsM h g (BS.ByteString, Bool)-flushAppData t = do- lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAppData\n"+flushAd :: (HandleLike h, CPRG g) =>+ TlsHandleBase h g -> M.TlsM h g (BS.ByteString, Bool)+flushAd t = do+ lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAd\n" ct <- getContentType t lift . lift $ hlDebug (tlsHandle t) "low" "after getContentType\n" case ct of- CTAppData -> do+ M.CTAppData -> do 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+ (bs, b) <- flushAd 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+ M.CTAlert -> do+ (_, a) <- buffered t 2 lift . lift $ hlDebug (tlsHandle t) "low" . BSC.pack $ show a case a of "\1\0" -> return ("", False)- _ -> throwError "flushAppData"+ _ -> throwError "flushAd" _ -> 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- _ -> return hh--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+chGet :: (HandleLike h, CPRG g) =>+ TlsHandleBase h g -> Int -> M.TlsM h g (Either Word8 BS.ByteString)+chGet _ 0 = return $ Right ""+chGet t n = do+ lift . lift . hlDebug (tlsHandle t) "critical" .+ BSC.pack . (++ "\n") $ show n+ ct <- getContentType t+ lift . lift . hlDebug (tlsHandle t) "critical" .+ BSC.pack . (++ "\n") $ show ct+ case ct of+ M.CTCCSpec -> do+ (M.CTCCSpec, bs) <- buffered t 1+ resetSequenceNumber t M.Read+ return . Left . (\[w] -> w) $ BS.unpack bs+ M.CTHandshake -> do+ (M.CTHandshake, bs) <- buffered t n+ return $ Right bs+ M.CTAlert -> do+ (M.CTAlert, al) <- buffered t 2+ throw M.ALFatal M.ADUnclasified $ show al+ _ -> throwError "not handshake" buffered :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> Int -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> Int -> M.TlsM h g (M.ContentType, BS.ByteString) buffered t n = do- (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b+ (ct, b) <- M.getRBuf $ partnerId t; let rl = n - BS.length b if rl <= 0 then splitRetBuf t n ct b else do (ct', b') <- getWholeWithCt t- unless (ct' == ct) . throwError . strMsg $+ unless (ct' == ct) . throw M.ALFatal M.ADUnclasified $ "Content Type confliction\n" ++ "\tExpected: " ++ show ct ++ "\n" ++ "\tActual : " ++ show ct' ++ "\n" ++ "\tData : " ++ show b' when (BS.null b') $ throwError "buffered: No data available"- setBuf (clientId t) (ct', b')+ M.setRBuf (partnerId t) (ct', b') second (b `BS.append`) `liftM` buffered t rl -buffered_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> TlsM h g ()) ->- TlsHandleBase h g -> Int -> TlsM h g (ContentType, BS.ByteString)+adGet :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->+ TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString+adGet rn t n = buffered_ rn t n++buffered_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->+ TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString buffered_ rn t n = do ct0 <- getContentType t case ct0 of- CTHandshake -> rn t >> buffered_ rn t n- _ -> do (ct, b) <- getBuf $ clientId t; let rl = n - BS.length b+ M.CTHandshake -> rn t >> buffered_ rn t n+ M.CTAlert -> do+ (M.CTAlert, b) <- M.getRBuf $ partnerId t+ let rl = 2 - BS.length b+ al <- if rl <= 0+ then snd `liftM` splitRetBuf t 2 M.CTAlert b+ else do (ct', b') <- getWholeWithCt t+ unless (ct' == M.CTAlert) $ throw+ M.ALFatal M.ADUnclasified+ "Content Type confliction\n"+ when (BS.null b') $ throwError "buffered: No data"+ M.setRBuf (partnerId t) (ct', b')+ (b `BS.append`) `liftM` buffered_ rn t rl+ case al of+ "\SOH\NULL" -> do+ tlsPut t M.CTAlert "\SOH\NULL"+ throw M.ALFatal M.ADUnclasified "EOF"+ _ -> throw M.ALFatal M.ADUnclasified $+ "Alert: " ++ show al+ _ -> do (ct, b) <- M.getRBuf $ partnerId t; let rl = n - BS.length b if rl <= 0- then splitRetBuf t n ct b- else do (ct', b') <- getWholeWithCt t- unless (ct' == ct) . throwError . strMsg $+ then snd `liftM` splitRetBuf t n ct b+ else do+ (ct', b') <- getWholeWithCt t+ unless (ct' == ct) $ throw M.ALFatal M.ADUnclasified "Content Type confliction\n" when (BS.null b') $ throwError "buffered: No data"- setBuf (clientId t) (ct', b')- second (b `BS.append`) `liftM` buffered_ rn t rl+ M.setRBuf (partnerId t) (ct', b')+ (b `BS.append`) `liftM` buffered_ rn t rl splitRetBuf :: HandleLike h =>- TlsHandleBase h g -> Int -> ContentType -> BS.ByteString ->- TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> Int -> M.ContentType -> BS.ByteString ->+ M.TlsM h g (M.ContentType, BS.ByteString) splitRetBuf t n ct b = do let (ret, b') = BS.splitAt n b- setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')+ M.setRBuf (partnerId t) $ if BS.null b' then (M.CTNull, "") else (ct, b') return (ct, ret) getWholeWithCt :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> M.TlsM h g (M.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+ ct <- (either (throw M.ALFatal M.ADUnclasified) return . B.decode) =<< rd 1+ [_vmj, _vmn] <- BS.unpack `liftM` rd 2+ e <- rd =<< either (throw M.ALFatal M.ADUnclasified) return . B.decode =<< rd 2 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+ M.tDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct+ M.tDebug (tlsHandle t) "medium" . BSC.pack . (++ "\n") . show $ BS.head p+ M.tDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p return (ct, p)--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 $- "TlsHandleBase.read: can't read " ++ show (BS.length r) ++ " " ++ show n- return r+ where rd n = do+ r <- M.tGet (tlsHandle t) n+ unless (BS.length r == n) . throw M.ALFatal M.ADUnclasified $+ "TlsHandleBase.rd: can't read " ++ show (BS.length r) ++ " " ++ show n+ return r decrypt :: HandleLike h =>- TlsHandleBase h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+ TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString decrypt t ct e = do- ks <- getKeys $ clientId t+ ks <- M.getKeys $ partnerId t decrypt_ t ks ct e decrypt_ :: HandleLike h => TlsHandleBase h g ->- Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e+ M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString+decrypt_ _ M.Keys{ M.kReadCS = M.CipherSuite _ M.BE_NULL } _ e = return e decrypt_ t ks ct e = do- let CipherSuite _ be = kReadCS ks- wk = kReadKey ks- mk = kReadMacKey ks- sn <- updateSequenceNumber t Read+ let M.CipherSuite _ be = M.kReadCS ks+ wk = M.kReadKey ks+ mk = M.kReadMacKey ks+ sn <- updateSequenceNumber t M.Read hs <- case be of- AES_128_CBC_SHA -> return CT.hashSha1- AES_128_CBC_SHA256 -> return CT.hashSha256+ M.AES_128_CBC_SHA -> return C.hashSha1+ M.AES_128_CBC_SHA256 -> return C.hashSha256 _ -> 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+ either (throw M.ALFatal M.ADUnclasified) return $+ C.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e -tlsPut :: (HandleLike h, CPRG g) => Bool ->- HandleHash h g -> ContentType -> BS.ByteString -> TlsM h g (HandleHash h g)-tlsPut b hh@(t, _) ct p = do- (bct, bp) <- getWBuf $ clientId t+tlsPut :: (HandleLike h, CPRG g) =>+ TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g ()+tlsPut t ct p = do+ (bct, bp) <- M.getWBuf $ partnerId t case ct of- CTCCSpec -> flush t >> setWBuf (clientId t) (ct, p) >> flush t- _ | bct /= CTNull && ct /= bct ->- flush t >> setWBuf (clientId t) (ct, p)- | otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p)- case (ct, b) of- _ -> return hh+ M.CTCCSpec -> flush t >> M.setWBuf (partnerId t) (ct, p) >> flush t+ _ | bct /= M.CTNull && ct /= bct ->+ flush t >> M.setWBuf (partnerId t) (ct, p)+ | otherwise -> M.setWBuf (partnerId t) (ct, bp `BS.append` p) -flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> TlsM h g ()+flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g () flush t = do- (bct, bp) <- getWBuf $ clientId t- setWBuf (clientId t) (CTNull, "")- unless (bct == CTNull) $ do+ (bct, bp) <- M.getWBuf $ partnerId t+ M.setWBuf (partnerId t) (M.CTNull, "")+ unless (bct == M.CTNull) $ do e <- encrypt t bct bp- thlPut (tlsHandle t) $ BS.concat [+ M.tPut (tlsHandle t) $ BS.concat [ B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ] encrypt :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+ TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString encrypt t ct p = do- ks <- getKeys $ clientId t+ ks <- M.getKeys $ partnerId t encrypt_ t ks ct p 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+ M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString+encrypt_ _ M.Keys{ M.kWriteCS = M.CipherSuite _ M.BE_NULL } _ p = return p encrypt_ t ks ct p = do- let CipherSuite _ be = kWriteCS ks- wk = kWriteKey ks- mk = kWriteMacKey ks- sn <- updateSequenceNumber t Write+ let M.CipherSuite _ be = M.kWriteCS ks+ wk = M.kWriteKey ks+ mk = M.kWriteMacKey ks+ sn <- updateSequenceNumber t M.Write hs <- case be of- AES_128_CBC_SHA -> return CT.hashSha1- AES_128_CBC_SHA256 -> return CT.hashSha256+ M.AES_128_CBC_SHA -> return C.hashSha1+ M.AES_128_CBC_SHA256 -> return C.hashSha256 _ -> 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)+ M.withRandom $ C.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p -updateSequenceNumber :: HandleLike h => TlsHandleBase h g -> RW -> TlsM h g Word64+updateSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g Word64 updateSequenceNumber t rw = do- ks <- getKeys $ clientId t+ ks <- M.getKeys $ partnerId t (sn, cs) <- case rw of- Read -> (, kReadCS ks) `liftM` getReadSn (clientId t)- Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t)+ M.Read -> (, M.kReadCS ks) `liftM` M.getRSn (partnerId t)+ M.Write -> (, M.kWriteCS ks) `liftM` M.getWSn (partnerId t) case cs of- CipherSuite _ BE_NULL -> return ()+ M.CipherSuite _ M.BE_NULL -> return () _ -> case rw of- Read -> succReadSn $ clientId t- Write -> succWriteSn $ clientId t+ M.Read -> M.sccRSn $ partnerId t+ M.Write -> M.sccWSn $ partnerId t return sn -resetSequenceNumber :: HandleLike h => TlsHandleBase h g -> RW -> TlsM h g ()+resetSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g () resetSequenceNumber t rw = case rw of- Read -> resetReadSn $ clientId t- Write -> resetWriteSn $ clientId t+ M.Read -> M.rstRSn $ partnerId t+ M.Write -> M.rstWSn $ partnerId t -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+makeKeys :: HandleLike h =>+ TlsHandleBase h g -> C.Side -> BS.ByteString -> BS.ByteString ->+ BS.ByteString -> M.CipherSuite -> M.TlsM h g M.Keys+makeKeys t p cr sr pms cs = do+ let M.CipherSuite _ be = cs kl <- case be of- AES_128_CBC_SHA -> return 20- AES_128_CBC_SHA256 -> return 32+ M.AES_128_CBC_SHA -> return 20+ M.AES_128_CBC_SHA256 -> return 32 _ -> throwError- "TlsServer.generateKeys: not implemented bulk encryption"- let (ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms- k <- getKeys $ clientId t+ "TlsServer.makeKeys: not implemented bulk encryption"+ let (ms, cwmk, swmk, cwk, swk) = C.makeKeys kl cr sr pms+ k <- M.getKeys $ partnerId t return $ case p of- Client -> k {- kCachedCS = cs,- kMasterSecret = ms,- kCachedReadMacKey = swmk, kCachedWriteMacKey = cwmk,- kCachedReadKey = swk, kCachedWriteKey = cwk }- Server -> k {- kCachedCS = cs,- kMasterSecret = ms,- kCachedReadMacKey = cwmk, kCachedWriteMacKey = swmk,- kCachedReadKey = cwk, kCachedWriteKey = swk }--data RW = Read | Write deriving Show+ C.Client -> k {+ M.kCachedCS = cs,+ M.kMasterSecret = ms,+ M.kCachedReadMacKey = swmk, M.kCachedWriteMacKey = cwmk,+ M.kCachedReadKey = swk, M.kCachedWriteKey = cwk }+ C.Server -> k {+ M.kCachedCS = cs,+ M.kMasterSecret = ms,+ M.kCachedReadMacKey = cwmk, M.kCachedWriteMacKey = swmk,+ M.kCachedReadKey = cwk, M.kCachedWriteKey = swk } -flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g ()-flushCipherSuiteSt p = case p of- Read -> flushCipherSuiteRead- Write -> flushCipherSuiteWrite+flushCipherSuite :: HandleLike h => M.RW -> TlsHandleBase h g -> M.TlsM h g ()+flushCipherSuite rw = M.flushCipherSuite rw . partnerId -debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> TlsM h g ()+debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> M.TlsM h g () debugCipherSuite t a = do- k <- getKeys $ clientId t- thlDebug (tlsHandle t) "high" . BSC.pack+ k <- M.getKeys $ partnerId t+ M.tDebug (tlsHandle t) "high" . BSC.pack . (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50- . show $ kCachedCS k+ . show $ M.kCachedCS k where lenSpace n str = str ++ replicate (n - length str) ' ' -handshakeHash :: HandleLike h => HandleHash h g -> TlsM h g BS.ByteString-handshakeHash = return . SHA256.finalize . snd--finishedHash :: HandleLike h => HandleHash h g -> Side -> TlsM h g BS.ByteString-finishedHash (t, ctx) partner = do- ms <- kMasterSecret `liftM` getKeys (clientId t)- sha256 <- handshakeHash (t, ctx)- return $ CT.finishedHash (partner == Client) ms sha256--hlPut_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> TlsM h g ()-hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined)+finishedHash :: HandleLike h =>+ C.Side -> TlsHandleBase h g -> BS.ByteString -> M.TlsM h g BS.ByteString+finishedHash s t hs = do+ ms <- M.kMasterSecret `liftM` M.getKeys (partnerId t)+ return $ C.finishedHash s ms hs -hlDebug_ :: HandleLike h =>- TlsHandleBase h g -> DebugLevel h -> BS.ByteString -> TlsM h g ()-hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l+adPut, hlPut_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()+adPut = hlPut_+hlPut_ = ((>> return ()) .) . flip tlsPut M.CTAppData -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)+adDebug, hlDebug_ :: HandleLike h =>+ TlsHandleBase h g -> DebugLevel h -> BS.ByteString -> M.TlsM h g ()+adDebug = hlDebug_+hlDebug_ = M.tDebug . tlsHandle -tGetLine :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString)-tGetLine t = do- (bct, bp) <- getBuf $ clientId t- case splitLine bp of- Just (l, ls) -> setBuf (clientId t) (bct, ls) >> return (bct, l)- _ -> do cp <- getWholeWithCt t- setBuf (clientId t) cp- second (bp `BS.append`) `liftM` tGetLine t+adClose, hlClose_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g ()+adClose = hlClose_+hlClose_ t = tlsPut t M.CTAlert "\SOH\NUL" >> flush t >> M.tClose (tlsHandle t) -tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> TlsM h g ()) ->- TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString)+adGetLine, tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->+ TlsHandleBase h g -> M.TlsM h g BS.ByteString+adGetLine = tGetLine_ tGetLine_ rn t = do ct <- getContentType t case ct of- CTHandshake -> rn t >> tGetLine_ rn t- _ -> do (bct, bp) <- getBuf $ clientId t+ M.CTHandshake -> rn t >> tGetLine_ rn t+ M.CTAlert -> do+ (M.CTAlert, b) <- M.getRBuf $ partnerId t+ let rl = 2 - BS.length b+ al <- if rl <= 0+ then snd `liftM` splitRetBuf t 2 M.CTAlert b+ else do (ct', b') <- getWholeWithCt t+ unless (ct' == M.CTAlert) . throw M.ALFatal M.ADUnclasified $+ "Content Type confliction\n"+ when (BS.null b') $ throwError "buffered: No data"+ M.setRBuf (partnerId t) (ct', b')+ (b `BS.append`) `liftM` buffered_ rn t rl+ case al of+ "\SOH\NULL" -> do+ tlsPut t M.CTAlert "\SOH\NULL"+ throw M.ALFatal M.ADUnclasified "EOF"+ _ -> throw M.ALFatal M.ADUnclasified $+ "Alert: " ++ show al+ _ -> do (bct, bp) <- M.getRBuf $ partnerId t case splitLine bp of Just (l, ls) -> do- setBuf (clientId t) (if BS.null ls then CTNull else bct, ls)- return (bct, l)+ M.setRBuf (partnerId t) (if BS.null ls then M.CTNull else bct, ls)+ return l _ -> do cp <- getWholeWithCt t- setBuf (clientId t) cp- second (bp `BS.append`) `liftM`- tGetLine_ rn t+ M.setRBuf (partnerId t) cp+ (bp `BS.append`) `liftM` tGetLine_ rn t splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of@@ -382,36 +409,88 @@ _ -> Nothing tGetContent :: (HandleLike h, CPRG g) =>- TlsHandleBase h g -> TlsM h g (ContentType, BS.ByteString)+ TlsHandleBase h g -> M.TlsM h g (M.ContentType, BS.ByteString) tGetContent t = do- bcp@(_, bp) <- getBuf $ clientId t+ bcp@(_, bp) <- M.getRBuf $ partnerId t if BS.null bp then getWholeWithCt t else- setBuf (clientId t) (CTNull, BS.empty) >> return bcp+ M.setRBuf (partnerId t) (M.CTNull, BS.empty) >> return bcp -getClientFinishedT, getServerFinishedT ::- HandleLike h => TlsHandleBase h g -> TlsM h g BS.ByteString-getClientFinishedT = getClientFinished . clientId-getServerFinishedT = getServerFinished . clientId+getClFinished, getSvFinished ::+ HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString+getClFinished = M.getClFinished . partnerId+getSvFinished = M.getSvFinished . partnerId -setClientFinishedT, setServerFinishedT ::- HandleLike h => TlsHandleBase h g -> BS.ByteString -> TlsM h g ()-setClientFinishedT = setClientFinished . clientId-setServerFinishedT = setServerFinished . clientId+setClFinished, setSvFinished ::+ HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()+setClFinished = M.setClFinished . partnerId+setSvFinished = M.setSvFinished . partnerId -getSettingsT :: HandleLike h => TlsHandleBase h g -> TlsM h g Settings-getSettingsT = getSettings . clientId+getSettingsS :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsS+getSettingsS = M.getSettingsS . partnerId -getInitSetT :: HandleLike h => TlsHandleBase h g -> TlsM h g SettingsS-getInitSetT = getInitSet . clientId+setSettingsS :: HandleLike h => TlsHandleBase h g -> M.SettingsS -> M.TlsM h g ()+setSettingsS = M.setSettingsS . partnerId -setSettingsT :: HandleLike h => TlsHandleBase h g -> Settings -> TlsM h g ()-setSettingsT = setSettings . clientId+getBuf :: HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString+getBuf = M.getAdBuf . partnerId -setInitSetT :: HandleLike h => TlsHandleBase h g -> SettingsS -> TlsM h g ()-setInitSetT = setInitSet . clientId+setBuf :: HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()+setBuf = M.setAdBuf . partnerId -getAdBufT :: HandleLike h => TlsHandleBase h g -> TlsM h g BS.ByteString-getAdBufT = getAdBuf . clientId+adGetContent, tGetContent_ :: (HandleLike h, CPRG g) =>+ (TlsHandleBase h g -> M.TlsM h g ()) ->+ TlsHandleBase h g -> M.TlsM h g BS.ByteString+adGetContent = tGetContent_+tGetContent_ rn t = do+ ct <- getContentType t+ case ct of+ M.CTHandshake -> rn t >> tGetContent_ rn t+ M.CTAlert -> do+ (M.CTAlert, al) <- buffered t 2+ case al of+ "\SOH\NULL" -> do+ tlsPut t M.CTAlert "\SOH\NUL"+ throw M.ALFatal M.ADUnclasified $+ ".checkAppData: EOF"+ _ -> throw M.ALFatal M.ADUnclasified $+ "Alert: " ++ show al+ _ -> snd `liftM` tGetContent t -setAdBufT :: HandleLike h => TlsHandleBase h g -> BS.ByteString -> TlsM h g ()-setAdBufT = setAdBuf . clientId+hsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()+hsPut = flip tlsPut M.CTHandshake++ccsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> Word8 -> M.TlsM h g ()+ccsPut t w = do+ ret <- tlsPut t M.CTCCSpec $ BS.pack [w]+ resetSequenceNumber t M.Write+ return ret++getSettingsC :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsC+getSettingsC = M.getSettingsC . partnerId++setSettingsC :: HandleLike h => TlsHandleBase h g ->+ M.SettingsC -> M.TlsM h g ()+setSettingsC = M.setSettingsC . partnerId++getCipherSuite :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.CipherSuite+getCipherSuite = M.getCipherSuite . partnerId++setCipherSuite :: HandleLike h => TlsHandleBase h g -> M.CipherSuite -> M.TlsM h g ()+setCipherSuite = M.setCipherSuite . partnerId++getNames :: HandleLike h => TlsHandleBase h g -> M.TlsM h g [String]+getNames = M.getNames . partnerId++setNames :: HandleLike h => TlsHandleBase h g -> [String] -> M.TlsM h g ()+setNames = M.setNames . partnerId++setKeys :: HandleLike h => TlsHandleBase h g -> M.Keys -> M.TlsM h g ()+setKeys = M.setKeys . partnerId++throw :: HandleLike h => M.AlertLevel -> M.AlertDesc -> String -> M.TlsM h g a+throw = ((throwError .) .) . M.Alert++debug :: (HandleLike h, Show a) =>+ TlsHandleBase h g -> DebugLevel h -> a -> M.TlsM h g ()+debug t l x = lift . lift . hlDebug (tlsHandle t) l .+ BSC.pack . (++ "\n") $ show x
src/Network/PeyoTLS/Monad.hs view
@@ -1,36 +1,41 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE OverloadedStrings, PackageImports #-} module Network.PeyoTLS.Monad ( TlsM, evalTlsM, S.initState,- thlGet, thlPut, thlClose, thlDebug, thlError,- withRandom, randomByteString,- getBuf, setBuf, getWBuf, setWBuf,+ tGet, tPut, tClose, tDebug, thlError,+ withRandom,+ getRBuf, setRBuf, getWBuf, setWBuf, getAdBuf, setAdBuf,- getReadSn, getWriteSn, succReadSn, succWriteSn,- resetReadSn, resetWriteSn,- getCipherSuiteSt, setCipherSuiteSt,- flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,- getSettings, setSettings,- getInitSet, setInitSet, S.SettingsS, S.Settings,+ getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn,+ getCipherSuite, setCipherSuite,+ getNames, setNames,+ setKeys, getKeys,+ S.SettingsS, getSettingsS, setSettingsS, S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), S.ContentType(..), S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..), S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys, - getClientFinished, setClientFinished,- getServerFinished, setServerFinished,+ getClFinished, setClFinished,+ getSvFinished, setSvFinished, S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey,++ SettingsC, getSettingsC, setSettingsC,+ RW(..),+ flushCipherSuite, ) where +import Control.Arrow ((***)) import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift) import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify)-import "monads-tf" Control.Monad.Error (ErrorT, runErrorT)+import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError) import Data.Word (Word64) import Data.HandleLike (HandleLike(..))-import "crypto-random" Crypto.Random (CPRG, cprgGenerate) import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509 import qualified Network.PeyoTLS.State as S ( HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,@@ -41,12 +46,15 @@ setAdBuf, getAdBuf, getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, getCipherSuite, setCipherSuite,- flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,+ setNames, getNames,+ setKeys, getKeys, getSettings, setSettings, getInitSet, setInitSet, getClientFinished, setClientFinished, getServerFinished, setServerFinished, + flushCipherSuiteRead, flushCipherSuiteWrite,+ SettingsS, Settings, CertSecretKey(..), isRsaKey, isEcdsaKey, )@@ -57,9 +65,9 @@ TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a) evalTlsM = evalStateT . runErrorT -getBuf, getWBuf :: HandleLike h =>+getRBuf, getWBuf :: HandleLike h => S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString)-getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf+getRBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString getAdBuf = gets . S.getAdBuf@@ -67,79 +75,102 @@ setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g () setAdBuf = (modify .) . S.setAdBuf -setBuf, setWBuf :: HandleLike h =>+setRBuf, setWBuf :: HandleLike h => S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()-setBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf+setRBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf -getWriteSn, getReadSn :: HandleLike h => S.PartnerId -> TlsM h g Word64-getWriteSn = gets . S.getWriteSN; getReadSn = gets . S.getReadSN+getWSn, getRSn :: HandleLike h => S.PartnerId -> TlsM h g Word64+getWSn = gets . S.getWriteSN; getRSn = gets . S.getReadSN -succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()-succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN+sccWSn, sccRSn :: HandleLike h => S.PartnerId -> TlsM h g ()+sccWSn = modify . S.succWriteSN; sccRSn = modify . S.succReadSN -resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()-resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN+rstWSn, rstRSn :: HandleLike h => S.PartnerId -> TlsM h g ()+rstWSn = modify . S.resetWriteSN; rstRSn = modify . S.resetReadSN -getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite-getCipherSuiteSt = gets . S.getCipherSuite+getCipherSuite :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite+getCipherSuite = gets . S.getCipherSuite -setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()-setCipherSuiteSt = (modify .) . S.setCipherSuite+setCipherSuite :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()+setCipherSuite = (modify .) . S.setCipherSuite +getNames :: HandleLike h => S.PartnerId -> TlsM h g [String]+getNames = gets . S.getNames++setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g ()+setNames = (modify .) . S.setNames+ setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g () setKeys = (modify .) . S.setKeys getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys getKeys = gets . S.getKeys -getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS-getInitSet = gets . S.getInitSet+getSettingsS :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS+getSettingsS = gets . S.getInitSet 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+setSettingsS :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g ()+setSettingsS = (modify .) . S.setInitSet setSettings :: HandleLike h => S.PartnerId -> S.Settings -> TlsM h g () setSettings = (modify .) . S.setSettings -getClientFinished, getServerFinished ::+getClFinished, getSvFinished :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString-getClientFinished = gets . S.getClientFinished-getServerFinished = gets . S.getServerFinished+getClFinished = gets . S.getClientFinished+getSvFinished = gets . S.getServerFinished -setClientFinished, setServerFinished ::+setClFinished, setSvFinished :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()-setClientFinished = (modify .) . S.setClientFinished-setServerFinished = (modify .) . S.setServerFinished+setClFinished = (modify .) . S.setClientFinished+setSvFinished = (modify .) . S.setServerFinished +flushCipherSuite :: HandleLike h => RW -> S.PartnerId -> TlsM h g ()+flushCipherSuite rw = case rw of+ Read -> flushCipherSuiteRead+ Write -> flushCipherSuiteWrite+ flushCipherSuiteRead, flushCipherSuiteWrite :: HandleLike h => S.PartnerId -> TlsM h g () flushCipherSuiteRead = modify . S.flushCipherSuiteRead flushCipherSuiteWrite = modify . S.flushCipherSuiteWrite withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a-withRandom p = do- (x, g') <- p `liftM` gets S.randomGen- modify $ S.setRandomGen g'- return x--randomByteString :: (HandleLike h, CPRG g) => Int -> TlsM h g BS.ByteString-randomByteString = withRandom . cprgGenerate+withRandom p = p `liftM` gets S.randomGen >>=+ uncurry (flip (>>)) . (return *** modify . S.setRandomGen) -thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString-thlGet = ((lift . lift) .) . hlGet+tGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString+tGet = ((lift . lift) .) . hlGet -thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()-thlPut = ((lift . lift) .) . hlPut+tPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()+tPut = ((lift . lift) .) . hlPut -thlClose :: HandleLike h => h -> TlsM h g ()-thlClose = lift . lift . hlClose+tClose :: HandleLike h => h -> TlsM h g ()+tClose = lift . lift . hlClose -thlDebug :: HandleLike h =>+tDebug :: HandleLike h => h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()-thlDebug = (((lift . lift) .) .) . hlDebug+tDebug = (((lift . lift) .) .) . hlDebug thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a thlError = ((lift . lift) .) . hlError++getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g SettingsC+getSettingsC i = do+ (css, crts, mcs) <- getSettings i+ case mcs of+ Just cs -> return (css, crts, cs)+ _ -> throwError "Network.PeyoTLS.Base.getSettingsC"++setSettingsC :: HandleLike h => S.PartnerId -> SettingsC -> TlsM h g ()+setSettingsC i (css, crts, cs) = setSettings i (css, crts, Just cs)++type SettingsC = (+ [S.CipherSuite],+ [(S.CertSecretKey, X509.CertificateChain)],+ X509.CertificateStore )++data RW = Read | Write deriving Show
src/Network/PeyoTLS/Run.hs view
@@ -1,394 +1,194 @@-{-# 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, validateAlert,- TH.TlsHandleBase(..), TH.ContentType(..),- getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,- tlsGetContentType, tlsGet, tlsPut, tlsPutNH,- 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_,- getClFinished, getSvFinished, setClFinished, setSvFinished,-- resetSequenceNumber,-- getSettingsS, setSettingsS, TH.SettingsS,- getSettingsC, setSettingsC, TH.Settings,- flushAppData,-- getAdBuf, setAdBuf,- pushAdBuf,-- TH.CertSecretKey(..)- ) where+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-} -import Prelude hiding (read)+module Network.PeyoTLS.Run ( H.debug,+ H.TlsM, H.run, H.TlsHandleBase(..),+ adGet, adGetLine, adGetContent, H.adPut, H.adDebug, H.adClose,+ HandshakeM, execHandshakeM, rerunHandshakeM, withRandom,+ chGet, ccsPut, hsPut, updateHash, flushAd,+ H.CertSecretKey(..), H.isRsaKey, H.isEcdsaKey,+ H.SettingsC, getSettingsC, setSettingsC,+ H.SettingsS, getSettingsS, setSettingsS,+ getCipherSuite, setCipherSuite,+ getClFinished, getSvFinished, setClFinished, setSvFinished,+ H.getNames,+ H.RW(..), flushCipherSuite, makeKeys,+ H.Side(..), handshakeHash, finishedHash,+ H.ValidateHandle(..), handshakeValidate, validateAlert,+ H.AlertLevel(..), H.AlertDesc(..), debugCipherSuite, throw ) where -import Data.Word-import Control.Applicative-import qualified Data.ASN1.Types as ASN1+import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, second, (***)) import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift) import "monads-tf" Control.Monad.State (- StateT, evalStateT, execStateT, get, gets, put, modify)-import qualified "monads-tf" Control.Monad.Error as E (throwError)-import "monads-tf" Control.Monad.Error.Class (strMsg)+ StateT, evalStateT, execStateT, get, gets, modify )+import "monads-tf" Control.Monad.Error (throwError)+import Data.Word (Word8) import Data.HandleLike (HandleLike(..))-import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC+import qualified Data.ASN1.Types as ASN1 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.Hash.SHA256 as SHA256 -import qualified Network.PeyoTLS.Handle as TH (- updateHash,- TlsM, Alert(..), AlertLevel(..), AlertDesc(..),- run, withRandom, randomByteString,- TlsHandleBase(..), ContentType(..),- newHandle, getContentType, tlsGet, tlsPut, generateKeys,- debugCipherSuite,- getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys,- Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..),- hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine, tGetLine_,- getClientFinishedT, setClientFinishedT,- getServerFinishedT, setServerFinishedT,-- resetSequenceNumber,-- getSettingsT, setSettingsT, Settings,- getInitSetT, setInitSetT, SettingsS,- tlsGet_,- flushAppData,- getAdBufT,- setAdBufT,-+import qualified Network.PeyoTLS.Handle as H ( debug,+ TlsM, run, withRandom,+ TlsHandleBase(..), CipherSuite,+ newHandle, chGet, ccsPut, hsPut,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose,+ flushAd, getBuf, setBuf,+ getCipherSuite, setCipherSuite,+ SettingsC, getSettingsC, setSettingsC,+ SettingsS, getSettingsS, setSettingsS,+ getClFinished, getSvFinished, setClFinished, setSvFinished,+ makeKeys, setKeys,+ getNames, setNames,+ Side(..), finishedHash,+ RW(..), flushCipherSuite,+ ValidateHandle(..), tValidate, 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.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.TlsHandleBase h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandleBase h g, SHA256.Ctx))-tlsGet__ = TH.tlsGet True+ Alert(..), AlertLevel(..), AlertDesc(..), debugCipherSuite ) -tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) =>- (TH.TlsHandleBase h g -> TH.TlsM h g ()) ->- TH.TlsHandleBase h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)-tGetLine_ = TH.tGetLine_+modNm :: String+modNm = "Network.PeyoTLS.Run" -flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)-flushAppData_ = gets fst >>= lift . TH.flushAppData+type RenegoProc h g = H.TlsHandleBase h g -> H.TlsM h g () -tGetContent_ rn t = do- ct <- TH.getContentType t- case ct of- TH.CTHandshake -> rn t >> tGetContent_ rn t- _ -> TH.tGetContent t+adGet :: (HandleLike h, CPRG g) =>+ RenegoProc h g -> H.TlsHandleBase h g -> Int -> H.TlsM h g BS.ByteString+adGet rp t n = H.getBuf t >>= \b -> if BS.length b >= n+ then uncurry (>>) . (H.setBuf t *** return) $ BS.splitAt n b+ else BS.append b `liftM` H.adGet rp t (n - BS.length b) -tlsPut_ :: (HandleLike h, CPRG g) =>- (TH.TlsHandleBase h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandleBase h g, SHA256.Ctx)-tlsPut_ = TH.tlsPut True+adGetLine :: (HandleLike h, CPRG g) =>+ RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString+adGetLine rp t = H.getBuf t >>= \b -> if '\n' `BSC.elem` b || '\r' `BSC.elem` b+ then uncurry (>>) . (H.setBuf t *** return) $ case BSC.span (/= '\r') b of+ (_, "") -> second BS.tail $ BSC.span (/= '\n') b+ (l, ls) -> case BSC.uncons ls of+ Just ('\r', ls') -> case BSC.uncons ls' of+ Just ('\n', ls'') -> (l, ls'')+ _ -> (l, ls')+ _ -> (l, ls)+ else (b `BS.append`) `liftM` H.adGetLine rp t -throwError :: HandleLike h =>- TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a-throwError al ad m = E.throwError $ TH.Alert al ad m+adGetContent :: (HandleLike h, CPRG g) =>+ RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString+adGetContent rp t = H.getBuf t >>= \b ->+ if BS.null b then H.adGetContent rp t else H.setBuf t "" >> return b -type HandshakeM h g = StateT (TH.TlsHandleBase h g, SHA256.Ctx) (TH.TlsM h g)+type HandshakeM h g = StateT (H.TlsHandleBase h g, SHA256.Ctx) (H.TlsM h g) -execHandshakeM :: HandleLike h =>- h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandleBase h g)+execHandshakeM ::+ HandleLike h => h -> HandshakeM h g () -> H.TlsM h g (H.TlsHandleBase h g) execHandshakeM h =- liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT+ liftM fst . ((, SHA256.init) `liftM` H.newHandle h >>=) . execStateT rerunHandshakeM ::- HandleLike h => TH.TlsHandleBase h g -> HandshakeM h g a -> TH.TlsM h g a-rerunHandshakeM t hm = evalStateT hm (t, SHA256.init)+ HandleLike h => H.TlsHandleBase h g -> HandshakeM h g a -> H.TlsM h g a+rerunHandshakeM = flip evalStateT . (, SHA256.init) withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a-withRandom = lift . TH.withRandom--randomByteString :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString-randomByteString = lift . TH.randomByteString--class HandleLike h => ValidateHandle h where- 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- validationChecks cs validationCache ("", "") $- X509.CertificateChain cc- where- validationCache = X509.ValidationCache- (\_ _ _ -> return X509.ValidationCacheUnknown)- (\_ _ _ -> return ())- validationChecks = X509.defaultChecks { X509.checkFQHN = False }+withRandom = lift . H.withRandom -certNames :: X509.Certificate -> [String]-certNames = nms- where- nms c = maybe id (:) <$> nms_ <*> ans $ c- nms_ = (ASN1.asn1CharacterToString =<<) .- X509.getDnElement X509.DnCommonName . X509.certSubjectDN- ans = maybe [] ((\ns -> [s | X509.AltNameDNS s <- ns])- . \(X509.ExtSubjectAltName ns) -> ns)- . X509.extensionGet . X509.certExtensions+chGet :: (HandleLike h, CPRG g) => HandshakeM h g (Either Word8 BS.ByteString)+chGet = gets fst >>= lift . flip H.chGet 1 >>= \ch -> case ch of+ Left w -> return $ Left w+ Right t -> Right `liftM` do+ len <- hsGet 3+ body <- hsGet . either error id $ B.decode len+ return $ BS.concat [t, len, body] -handshakeValidate :: ValidateHandle h =>- 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 $ head c }- lift . lift . lift $ validate (TH.tlsHandle t) cs cc+hsGet :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString+hsGet n = gets fst >>= lift . flip H.chGet n >>= \ch -> case ch of+ Right bs -> return bs+ _ -> throw H.ALFatal H.ADUnexMsg $ modNm ++ ".hsGet: not handshake" -setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()-setCipherSuite cs = do- t <- gets fst- lift $ TH.setCipherSuiteSt (TH.clientId t) cs+ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g ()+ccsPut = (gets fst >>=) . (lift .) . flip H.ccsPut -getCipherSuite :: HandleLike h => HandshakeM h g TH.CipherSuite-getCipherSuite = do- t <- gets fst- lift . TH.getCipherSuiteSt $ TH.clientId t+hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g ()+hsPut = (gets fst >>=) . (lift .) . flip H.hsPut -flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g ()-flushCipherSuite p = do- t <- gets fst- lift $ TH.flushCipherSuiteSt p (TH.clientId t)+updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g ()+updateHash = modify . second . flip SHA256.update -debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()-debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m+flushAd :: (HandleLike h, CPRG g) => HandshakeM h g Bool+flushAd = gets fst >>= lift . H.flushAd >>= uncurry (>>) . (push *** return)+ where push bs = gets fst >>= lift . H.getBuf >>=+ (gets fst >>=) . (lift .) . flip H.setBuf . (`BS.append` bs) -tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType-tlsGetContentType = gets fst >>= lift . TH.getContentType+getSettingsC :: HandleLike h => HandshakeM h g H.SettingsC+getSettingsC = gets fst >>= lift . H.getSettingsC -tlsGet :: (HandleLike h, CPRG g) => Bool -> Int -> HandshakeM h g BS.ByteString-tlsGet b n = do ((_, bs), t') <- lift . flip (TH.tlsGet b) n =<< get; put t'; return bs+setSettingsC :: HandleLike h => H.SettingsC -> HandshakeM h g ()+setSettingsC = (gets fst >>=) . (lift .) . flip H.setSettingsC -tlsPut, tlsPutNH :: (HandleLike h, CPRG g) =>- TH.ContentType -> BS.ByteString -> HandshakeM h g ()-tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut True t ct bs) >>= put-tlsPutNH ct bs = get >>= lift . (\t -> TH.tlsPut False t ct bs) >>= put+getSettingsS :: HandleLike h => HandshakeM h g H.SettingsS+getSettingsS = gets fst >>= lift . H.getSettingsS -generateKeys :: HandleLike h => TH.Side ->- (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g ()-generateKeys p (cr, sr) pms = do- t <- gets fst- cs <- lift $ TH.getCipherSuiteSt (TH.clientId t)- k <- lift $ TH.generateKeys t p cs cr sr pms- lift $ TH.setKeys (TH.clientId t) k+setSettingsS :: HandleLike h => H.SettingsS -> HandshakeM h g ()+setSettingsS = (gets fst >>=) . (lift .) . flip H.setSettingsS -handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString-handshakeHash = get >>= lift . TH.handshakeHash+getCipherSuite :: HandleLike h => HandshakeM h g H.CipherSuite+getCipherSuite = gets fst >>= lift . H.getCipherSuite -finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString-finishedHash p = get >>= lift . flip TH.finishedHash p+setCipherSuite :: HandleLike h => H.CipherSuite -> HandshakeM h g ()+setCipherSuite = (gets fst >>=) . (lift .) . flip H.setCipherSuite getClFinished, getSvFinished :: HandleLike h => HandshakeM h g BS.ByteString-getClFinished = gets fst >>= lift . TH.getClientFinishedT-getSvFinished = gets fst >>= lift . TH.getServerFinishedT+getClFinished = gets fst >>= lift . H.getClFinished+getSvFinished = gets fst >>= lift . H.getSvFinished 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--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--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--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.TlsHandleBase h g -> BS.ByteString -> TH.TlsM h g ()-setAdBuf = TH.setAdBufT--getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString-getAdBufH = gets fst >>= lift . TH.getAdBufT--setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g ()-setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs--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+setClFinished = (gets fst >>=) . (lift .) . flip H.setClFinished+setSvFinished = (gets fst >>=) . (lift .) . flip H.setSvFinished -hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g ()-hsPut = tlsPut TH.CTHandshake+flushCipherSuite :: (HandleLike h, CPRG g) => H.RW -> HandshakeM h g ()+flushCipherSuite = (gets fst >>=) . (lift .) . H.flushCipherSuite -ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g ()-ccsPut w = do- tlsPut TH.CTCCSpec $ BS.pack [w]- resetSequenceNumber TH.Write+makeKeys :: HandleLike h => H.Side ->+ (BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g ()+makeKeys s (cr, sr) pms = gets fst >>= \t -> lift $+ H.getCipherSuite t >>= H.makeKeys t s cr sr pms >>= H.setKeys t -updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g ()-updateHash bs = get >>= lift . flip TH.updateHash bs >>= put+handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString+handshakeHash = SHA256.finalize `liftM` gets snd -flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g Bool-flushAppData = uncurry (>>) . (pushAdBuf *** return) =<< flushAppData_+finishedHash :: (HandleLike h, CPRG g) => H.Side -> HandshakeM h g BS.ByteString+finishedHash s = get >>= lift . uncurry (H.finishedHash s) . second SHA256.finalize -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)+validateAlert :: [X509.FailedReason] -> H.AlertDesc+validateAlert vr+ | X509.UnknownCA `elem` vr = H.ADUnknownCa+ | X509.Expired `elem` vr = H.ADCertificateExpired+ | X509.InFuture `elem` vr = H.ADCertificateExpired+ | otherwise = H.ADCertificateUnknown -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+handshakeValidate :: H.ValidateHandle h => X509.CertificateStore ->+ X509.CertificateChain -> HandshakeM h g [X509.FailedReason]+handshakeValidate cs cc@(X509.CertificateChain (c : _)) = gets fst >>= \t -> do+ lift . H.setNames t . certNames $ X509.getCertificate c+ modify . first $ const t { H.names = certNames $ X509.getCertificate c }+ lift $ H.tValidate t cs cc+handshakeValidate _ _ = error $ modNm ++ ".handshakeValidate: empty cert chain" -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)+certNames :: X509.Certificate -> [String]+certNames = maybe id (:) <$> nm <*> nms+ where+ nm = (ASN1.asn1CharacterToString =<<) .+ X509.getDnElement X509.DnCommonName . X509.certSubjectDN+ nms = maybe [] ((\ns -> [s | X509.AltNameDNS s <- ns])+ . \(X509.ExtSubjectAltName ns) -> ns)+ . X509.extensionGet . X509.certExtensions -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+debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()+debugCipherSuite = (gets fst >>=) . (lift .) . flip H.debugCipherSuite -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+throw :: HandleLike h => H.AlertLevel -> H.AlertDesc -> String -> HandshakeM h g a+throw = ((throwError .) .) . H.Alert
src/Network/PeyoTLS/Server.hs view
@@ -12,7 +12,7 @@ module Network.PeyoTLS.Server ( -- * Basic- PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names,+ PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames, -- * Renegotiation renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, -- * Cipher Suite@@ -30,7 +30,7 @@ import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import Numeric (readHex)-import "crypto-random" Crypto.Random (CPRG, SystemRNG)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate) import qualified "monads-tf" Control.Monad.Error as E import qualified Data.ByteString as BS@@ -42,18 +42,17 @@ 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 qualified Network.PeyoTLS.Base as BASE (names, getNames) import Network.PeyoTLS.Base ( debug, PeyotlsM, TlsM, run, SettingsS, getSettingsS, setSettingsS,- adGet, adGetLine, adGetContent,+ adGet, adGetLine, adGetContent, adPut, adDebug, adClose, HandshakeM, execHandshakeM, rerunHandshakeM,- withRandom, randomByteString, flushAppData,- AlertLevel(..), AlertDesc(..), throwError, debugCipherSuite,+ withRandom, flushAd,+ AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, ValidateHandle(..), handshakeValidate, validateAlert, TlsHandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,- readHandshake, writeHandshake,- getChangeCipherSpec, putChangeCipherSpec,+ readHandshake, writeHandshake, ChangeCipherSpec(..), Handshake(HHelloReq), ClientHello(..), ServerHello(..), SessionId(..), Extension(..), isRenegoInfo, emptyRenegoInfo,@@ -64,11 +63,11 @@ ServerKeyEx(..), SvSignSecretKey(..), certReq, ClCertType(..), ServerHelloDone(..),- ClientKeyEx(..), Epms(..), generateKeys,+ ClientKeyEx(..), Epms(..), makeKeys, DigitallySigned(..), ClSignPublicKey(..), handshakeHash, RW(..), flushCipherSuite, Side(..), finishedHash,- DhParam(..), makeEcdsaPubKey )+ DhParam(..), ecdsaPubKey ) type PeyotlsHandle = TlsHandle Handle SystemRNG @@ -77,12 +76,12 @@ 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+ hlPut = adPut . tlsHandleS hlGet = adGet rehandshake . tlsHandleS hlGetLine = adGetLine rehandshake . tlsHandleS hlGetContent = adGetContent rehandshake . tlsHandleS- hlDebug (TlsHandleS t) = hlDebug t- hlClose (TlsHandleS t) = hlClose t+ hlDebug = adDebug . tlsHandleS+ hlClose = adClose . tlsHandleS type Version = (Word8, Word8) @@ -92,9 +91,14 @@ moduleName :: String moduleName = "Network.PeyoTLS.Server" +{-# DEPRECATED names "Use getNames instead" #-}+ names :: TlsHandle h g -> [String] names = BASE.names . tlsHandleS +getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]+getNames = BASE.getNames . tlsHandleS+ open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g)@@ -135,9 +139,9 @@ renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleS t) = rerunHandshakeM t $ do writeHandshake HHelloReq- debug "low" ("before flushAppData" :: String)- ne <- flushAppData- debug "low" ("after flushAppData" :: String)+ debug "low" ("before flushAd" :: String)+ ne <- flushAd+ debug "low" ("after flushAd" :: String) when ne (handshake =<< getSettingsS) rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g ()@@ -150,25 +154,27 @@ ha <- case be of AES_128_CBC_SHA -> return Sha1 AES_128_CBC_SHA256 -> return Sha256- _ -> throwError ALFatal ADInternalError $+ _ -> throw ALFatal ADInternalError $ pre ++ "not implemented bulk encryption type" 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 $+ _ -> \_ _ -> throw ALFatal ADInternalError $ pre ++ "no implemented key exchange type or " ++ "no applicable certificate files" flip (maybe $ return ()) mpk $ \pk -> case pk of X509.PubKeyRSA rpk -> certVerify rpk- X509.PubKeyECDSA c xy -> certVerify $ makeEcdsaPubKey c xy- _ -> throwError ALFatal ADUnsupportedCertificate $+ X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy+ _ -> throw ALFatal ADUnsupportedCertificate $ pre ++ "not implement: " ++ show pk- getChangeCipherSpec >> flushCipherSuite Read+ ChangeCipherSpec <- readHandshake+ flushCipherSuite Read (==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok .- throwError ALFatal ADDecryptError $ pre ++ "wrong finished hash"- putChangeCipherSpec >> flushCipherSuite Write+ throw ALFatal ADDecryptError $ pre ++ "wrong finished hash"+ writeHandshake ChangeCipherSpec+ flushCipherSuite Write writeHandshake =<< finishedHash Server where pre = moduleName ++ ".handshake: " @@ -200,13 +206,13 @@ clientHello cssv = do ClientHello cv cr _sid cscl cms me <- readHandshake checkRenegoInfo cscl me- unless (cv >= version) . throwError ALFatal ADProtocolVersion $+ unless (cv >= version) . throw ALFatal ADProtocolVersion $ pre ++ "only implement TLS 1.2"- unless (CompMethodNull `elem` cms) . throwError ALFatal ADDecodeError $+ unless (CompMethodNull `elem` cms) . throw 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 ADHsFailure $+ _ -> throw ALFatal ADHsFailure $ pre ++ "no acceptable set of security parameters: \n\t" ++ "cscl: " ++ show cscl ++ "\n\t" ++ "cssv: " ++ show cssv ++ "\n"@@ -215,7 +221,7 @@ checkRenegoInfo :: HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()-checkRenegoInfo cscl me = (\n -> maybe n checkClRenego mcf) . throwError+checkRenegoInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw ALFatal ADInsufficientSecurity $ moduleName ++ ".checkRenego: require secure renegotiation" where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of@@ -230,16 +236,16 @@ cs <- getCipherSuite ke <- case cs of CipherSuite k _ -> return k- _ -> throwError ALFatal ADInternalError $+ _ -> throw ALFatal ADInternalError $ moduleName ++ ".serverHello: never occur"- sr <- randomByteString 32+ sr <- withRandom $ cprgGenerate 32 writeHandshake . ServerHello version sr (SessionId "") cs CompMethodNull . Just . (: []) =<< makeSvRenego writeHandshake =<< case (ke, rcc, ecc) of (ECDHE_ECDSA, _, Just c) -> return c (_, Just c, _) -> return c- _ -> throwError ALFatal ADInternalError $+ _ -> throw ALFatal ADInternalError $ moduleName ++ ".serverHello: cert files not match" return sr @@ -248,14 +254,14 @@ HandshakeM h g (Maybe X509.PubKey) 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)+ makeKeys Server rs =<< mkpms epms `catchError` const+ ((BS.cons vj . BS.cons vn) `liftM` withRandom (cprgGenerate 46)) where mkpms epms = do pms <- either (E.throwError . strMsg . show) return =<< withRandom (\g -> RSA.decryptSafer g sk epms)- unless (BS.length pms == 48) $ throwError ALFatal ADHsFailure ""+ unless (BS.length pms == 48) $ throw ALFatal ADHsFailure "" let [pvj, pvn] = BS.unpack $ BS.take 2 pms- unless (pvj == vj && pvn == vn) $ throwError ALFatal ADHsFailure ""+ unless (pvj == vj && pvn == vn) $ throw ALFatal ADHsFailure "" return pms dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk,@@ -271,8 +277,8 @@ . ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] const `liftM` reqAndCert mcs `ap` do ClientKeyEx cke <- readHandshake- generateKeys Server rs . calculateShared dp sv =<<- either (throwError ALFatal ADInternalError .+ makeKeys Server rs . calculateShared dp sv =<<+ either (throw ALFatal ADInternalError . (moduleName ++) . (".dhKeyExchange: " ++)) return (B.decode cke) @@ -285,7 +291,7 @@ 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) $+ unless (null vr) . throw ALFatal (validateAlert vr) $ moduleName ++ ".reqAndCert: " ++ show vr return . X509.certPubKey $ X509.getCertificate c @@ -296,7 +302,7 @@ DigitallySigned a s <- readHandshake case a of (Sha256, sa) | sa == cspAlgorithm pk -> return ()- _ -> throwError ALFatal ADDecodeError $+ _ -> throw ALFatal ADDecodeError $ moduleName ++ ".certVerify: not implement: " ++ show a- unless (csVerify pk s hs0) . throwError ALFatal ADDecryptError $+ unless (csVerify pk s hs0) . throw ALFatal ADDecryptError $ moduleName ++ ".certVerify: client auth failed "
src/Network/PeyoTLS/State.hs view
@@ -17,6 +17,8 @@ SettingsS, Settings, CertSecretKey(..), isRsaKey, isEcdsaKey,++ getNames, setNames, ) where import Control.Applicative ((<$>))@@ -61,7 +63,8 @@ radBuffer = "", readSN = 0, writeSN = 0, rnClientFinished = "", rnServerFinished = "",- initialSettings = ([], [], Nothing)+ initialSettings = ([], [], Nothing),+ sNames = [] } sos = states s @@ -95,7 +98,8 @@ writeSN :: Word64, rnClientFinished :: BS.ByteString, rnServerFinished :: BS.ByteString,- initialSettings :: Settings+ initialSettings :: Settings,+ sNames :: [String] } getState :: PartnerId -> HandshakeState h g -> StateOne g@@ -154,12 +158,12 @@ data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show data AlertDesc- = ADCloseNotify | ADUnexpectedMessage | ADBadRecordMac+ = ADCloseNotify | ADUnexMsg | ADBadRecordMac | ADRecordOverflow | ADDecompressionFailure | ADHsFailure | ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown | ADIllegalParameter | ADUnknownCa | ADDecodeError | ADDecryptError | ADProtocolVersion | ADInsufficientSecurity- | ADInternalError+ | ADInternalError | ADUnclasified | ADRaw Word8 deriving Show @@ -191,6 +195,12 @@ setCipherSuite :: PartnerId -> CipherSuite -> Modify (HandshakeState h g) setCipherSuite i = modifyState i . \cs st -> st { sKeys = (sKeys st) { kCachedCS = cs } }++getNames :: PartnerId -> HandshakeState h g -> [String]+getNames i = sNames . fromJust' "getNames" . lookup i . states++setNames :: PartnerId -> [String] -> Modify (HandshakeState h g)+setNames i = modifyState i . \n st -> st { sNames = n } getKeys :: PartnerId -> HandshakeState h g -> Keys getKeys i = sKeys . fromJust' "getKeys" . lookup i . states
src/Network/PeyoTLS/Types.hs view
@@ -36,9 +36,10 @@ = HHelloReq | HClientHello ClientHello | HServerHello ServerHello | HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString- | HCertificateReq CertReq | HServerHelloDone+ | HCertificateReq CertReq | HServerHelloDone | HCertVerify DigitallySigned | HClientKeyEx ClientKeyEx | HFinished BS.ByteString | HRaw Type BS.ByteString+ | HCCSpec deriving Show instance B.Bytable Handshake where@@ -75,12 +76,19 @@ encodeH (HClientKeyEx epms) = encodeH . HRaw TClientKeyEx $ B.encode epms encodeH (HFinished bs) = encodeH $ HRaw TFinished bs encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen (undefined :: Word24) bs+encodeH HCCSpec = B.encode ChangeCipherSpec class HandshakeItem hi where fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake instance HandshakeItem Handshake where fromHandshake = Just; toHandshake = id++instance HandshakeItem ChangeCipherSpec where+ fromHandshake HCCSpec = Just ChangeCipherSpec+ fromHandshake _ = Nothing+ toHandshake ChangeCipherSpec = HCCSpec+ toHandshake (ChangeCipherSpecRaw _) = error "bad" instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where fromHandshake hs = let