peyotls 0.0.0.20 → 0.0.0.21

raw patch · 25 files changed

+1839/−1772 lines, 25 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/renegServer.hs +42/−0
• peyotls.cabal +10/−9
• src/Network/PeyoTLS/Base.hs +386/−0
• src/Network/PeyoTLS/CertSecretKey.hs +3/−1
• src/Network/PeyoTLS/Certificate.hs +1/−1
• src/Network/PeyoTLS/CipherSuite.hs +7/−7
• src/Network/PeyoTLS/Client.hs +42/−63
• src/Network/PeyoTLS/Crypto.hs +102/−0
• src/Network/PeyoTLS/CryptoTools.hs +0/−102
• src/Network/PeyoTLS/Extension.hs +1/−1
• src/Network/PeyoTLS/HSAlg.hs +42/−0
• src/Network/PeyoTLS/Handle.hs +401/−0
• src/Network/PeyoTLS/HandshakeBase.hs +0/−337
• src/Network/PeyoTLS/HandshakeMonad.hs +0/−237
• src/Network/PeyoTLS/HandshakeType.hs +0/−240
• src/Network/PeyoTLS/HashSignAlgorithm.hs +0/−42
• src/Network/PeyoTLS/Hello.hs +11/−11
• src/Network/PeyoTLS/Monad.hs +137/−0
• src/Network/PeyoTLS/Run.hs +249/−0
• src/Network/PeyoTLS/Server.hs +145/−179
• src/Network/PeyoTLS/State.hs +19/−12
• src/Network/PeyoTLS/TlsHandle.hs +0/−394
• src/Network/PeyoTLS/TlsMonad.hs +0/−135
• src/Network/PeyoTLS/Types.hs +240/−0
• test/testReneg.hs +1/−1

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+	d : _ <- getArgs+	k <- readKey $ d ++ "/localhost.sample_key"+	c <- readCertificateChain $ d ++ "/localhost.sample_crt"+	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	soc <- listenOn $ PortNumber 443+	void . (`runStateT` g0) . forever $ do+		(h, _, _) <- liftIO $ accept soc+		g <- StateT $ return . cprgFork+		liftIO . forkIO . (`run` g) $ do+			p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+				Nothing+			renegotiate p+			doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+--			renegotiate p+			hlPut p $ BS.concat [+				"HTTP/1.1 200 OK\r\n",+				"Transfer-Encoding: chunked\r\n",+				"Content-Type: text/plain\r\n\r\n",+				"5\r\nHello0\r\n\r\n" ]+			hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+	(if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.20+version:	0.0.0.21 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -253,6 +253,7 @@     examples/eccServer.hs     examples/eccClient.hs     examples/debugServer.hs+    examples/renegServer.hs  data-dir: data data-files:@@ -273,22 +274,22 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.20+    tag:	peyotls-0.0.0.21  library     hs-source-dirs:	src     exposed-modules:         Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile     other-modules:-        Network.PeyoTLS.HandshakeBase,-        Network.PeyoTLS.HandshakeType,+        Network.PeyoTLS.Base,+        Network.PeyoTLS.Types,             Network.PeyoTLS.Hello, Network.PeyoTLS.Extension,-                Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HashSignAlgorithm,+                Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HSAlg,             Network.PeyoTLS.Certificate,-        Network.PeyoTLS.HandshakeMonad,-            Network.PeyoTLS.TlsHandle,-                Network.PeyoTLS.TlsMonad, Network.PeyoTLS.State,-                Network.PeyoTLS.CryptoTools,+        Network.PeyoTLS.Run,+            Network.PeyoTLS.Handle,+                Network.PeyoTLS.Monad, Network.PeyoTLS.State,+                Network.PeyoTLS.Crypto,         Network.PeyoTLS.Ecdsa, Network.PeyoTLS.CertSecretKey     build-depends:         base == 4.*, word24 == 1.0.*, bytestring == 0.10.*, monads-tf == 0.1.*,

@@ -0,0 +1,386 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports,+	TupleSections #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Base ( Extension(..),+	PeyotlsM, eRenegoInfo,+	debug, generateKs, blindSign, HM.CertSecretKey(..), isEcdsaKey, isRsaKey,+	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM,+	HM.withRandom, HM.randomByteString,+	HM.TlsHandle, HM.names,+		readHandshake, getChangeCipherSpec,+		writeHandshake, putChangeCipherSpec,+		writeHandshakeNH,+	HM.ValidateHandle(..), HM.handshakeValidate,+	HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..),+	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+	ServerHelloDone(..),+	ClientHello(..), ServerHello(..), SessionId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..), HashAlg(..), SignAlg(..),+		HM.getCipherSuite, HM.setCipherSuite,+	CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..),+	ClientKeyExchange(..), Epms(..),+		HM.generateKeys,+		HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite,+	DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite,+	HM.Side(..), HM.RW(..), finishedHash,+	DhParam(..), dh3072Modp, secp256r1, HM.throwError,+	HM.getClientFinished, HM.getServerFinished,+	Finished(..),+	HM.ContentType(CTAlert, CTHandshake, CTAppData),+	Handshake(..),+	HM.tlsHandle,+	hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_,+	hlGetContentRn,++	HM.getSettings, HM.setSettings,+	HM.flushAppData_,+	flushAppData,+	HM.pushAdBufH,+	) where++import Control.Applicative+import Control.Arrow (first, second, (***))+import Control.Monad (liftM)+import "monads-tf" Control.Monad.State (gets, lift)+import qualified "monads-tf" Control.Monad.Error as E+import Data.Word (Word8)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import Numeric (readHex)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+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.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.Prim as RSA+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC+import qualified Crypto.PubKey.ECC.Prim as ECC+import qualified Crypto.Types.PubKey.ECDSA as ECDSA++import Network.PeyoTLS.Types ( Extension(..),+	Handshake(..), HandshakeItem(..),+	ClientHello(..), ServerHello(..), SessionId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..),+	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+		SignAlg(..), HashAlg(..),+	ServerHelloDone(..), ClientKeyExchange(..), Epms(..),+	DigitallySigned(..), Finished(..) )+import qualified Network.PeyoTLS.Run as HM (+	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM,+	withRandom, randomByteString,+	ValidateHandle(..), handshakeValidate,+	TlsHandle(..), ContentType(..),+		names,+		getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+		tlsGetContentType, tlsGet, tlsPut, tlsPutNH,+		generateKeys, encryptRsa, decryptRsa, rsaPadding,+	Alert(..), AlertLevel(..), AlertDesc(..),+	Side(..), RW(..), handshakeHash, finishedHash, throwError,+	hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_,+	tGetLine_, tGetContent_, tlsGet__,+	hlDebug_, hlClose_,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,+	resetSequenceNumber,++	getSettings, setSettings,+	flushAppData_,+	getAdBuf,+	setAdBuf,+	pushAdBufH,++	CertSecretKey(..),+	)+import Network.PeyoTLS.Ecdsa (blindSign, generateKs)++-- import Network.PeyoTLS.CertSecretKey++type PeyotlsM = HM.TlsM Handle SystemRNG++debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g ()+debug p x = do+	h <- gets $ HM.tlsHandle . fst+	lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x++readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi+readHandshake = do+	cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+	hs <- case cnt of+		CHandshake HHelloReq -> readHandshake+		CHandshake hs -> return hs+		_ -> HM.throwError+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.readHandshake: not handshake: " ++ show cnt+	case fromHandshake hs of+		Just i -> return i+		_ -> HM.throwError+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.readHandshake: type mismatch " ++ show hs++writeHandshake, writeHandshakeNH ::+	(HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g ()+writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake+writeHandshakeNH = uncurry HM.tlsPutNH . encodeContent . CHandshake . toHandshake++data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show++instance B.Bytable ChangeCipherSpec where+	decode bs = case BS.unpack bs of+		[1] -> Right ChangeCipherSpec+		[w] -> Right $ ChangeCipherSpecRaw w+		_ -> Left "HandshakeBase: ChangeCipherSpec.decode"+	encode ChangeCipherSpec = BS.pack [1]+	encode (ChangeCipherSpecRaw w) = BS.pack [w]++getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()+getChangeCipherSpec = do+	cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+	case cnt of+		CCCSpec ChangeCipherSpec -> return ()+		_ -> HM.throwError+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.getChangeCipherSpec: " +++			"not change cipher spec: " +++			show cnt+	HM.resetSequenceNumber HM.Read++putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()+putChangeCipherSpec = do+	uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec+	HM.resetSequenceNumber HM.Write++data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake+	deriving Show++readContent :: Monad m => (Bool -> Int -> m BS.ByteString) -> HM.ContentType -> m Content+readContent rd HM.CTCCSpec =+	(CCCSpec . either error id . B.decode) `liftM` rd True 1+readContent rd HM.CTAlert =+	((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd True 2+readContent rd HM.CTHandshake = CHandshake `liftM` do+	t <- rd True 1+	len <- rd (t /= "\0") 3+--	(t, len) <- (,) `liftM` rd True 1 `ap` rd True 3+	body <- rd True . either error id $ B.decode len+	return . either error id . B.decode $ BS.concat [t, len, body]+readContent _ _ = undefined++encodeContent :: Content -> (HM.ContentType, BS.ByteString)+encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs)+encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad])+encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss)++class SecretKey sk where+	type Blinder sk+	generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)+	sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString+	signatureAlgorithm :: sk -> SignAlg++instance SecretKey RSA.PrivateKey where+	type Blinder RSA.PrivateKey = RSA.Blinder+	generateBlinder sk rng =+		RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk+	sign hs bl sk bs = let+		(h, oid) = first ($ bs) $ case hs of+			Sha1 -> (SHA1.hash,+				ASN1.OID [1, 3, 14, 3, 2, 26])+			Sha256 -> (SHA256.hash,+				ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])+			_ -> error $ "HandshakeBase: " +++				"not implemented bulk encryption type"+		a = [ASN1.Start ASN1.Sequence,+			ASN1.Start ASN1.Sequence,+				oid, ASN1.Null, ASN1.End ASN1.Sequence,+			ASN1.OctetString h, ASN1.End ASN1.Sequence]+		b = ASN1.encodeASN1' ASN1.DER a+		pd = BS.concat [ "\x00\x01",+			BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ]+		ps = RSA.public_size $ RSA.private_pub sk in+		RSA.dp (Just bl) sk pd+	signatureAlgorithm _ = Rsa++instance SecretKey ECDSA.PrivateKey where+	type Blinder ECDSA.PrivateKey = Integer+	generateBlinder _ rng = let+		(Right bl, rng') = first B.decode $ cprgGenerate 32 rng in+		(bl, rng')+	sign ha bl sk = B.encode .+		(($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)+		where+		(hs, bls) = case ha of+			Sha1 -> (SHA1.hash, 64)+			Sha256 -> (SHA256.hash, 64)+			_ -> error $ "HandshakeBase: " +++				"not implemented bulk encryption type"+		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk+		x = ECDSA.private_d sk+	signatureAlgorithm _ = Ecdsa++class DhParam b where+	type Secret b+	type Public b+	generateSecret :: CPRG g => b -> g -> (Secret b, g)+	calculatePublic :: b -> Secret b -> Public b+	calculateShared :: b -> Secret b -> Public b -> BS.ByteString++instance DhParam DH.Params where+	type Secret DH.Params = DH.PrivateNumber+	type Public DH.Params = DH.PublicNumber+	generateSecret = flip DH.generatePrivate+	calculatePublic = DH.calculatePublic+	calculateShared ps sn pn = B.encode .+		(\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn++dh3072Modp :: DH.Params+dh3072Modp = DH.Params p 2+	where [(p, "")] = readHex $+		"ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" +++		"29024e088a67cc74020bbea63b139b22514a08798e3404dd" +++		"ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" +++		"e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" +++		"ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" +++		"c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" +++		"83655d23dca3ad961c62f356208552bb9ed529077096966d" +++		"670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" +++		"e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" +++		"de2bcbf6955817183995497cea956ae515d2261898fa0510" +++		"15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" +++		"ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" +++		"abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" +++		"f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" +++		"bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" +++		"43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"++instance DhParam ECC.Curve where+	type Secret ECC.Curve = Integer+	type Public ECC.Curve = ECC.Point+	generateSecret c = getRangedInteger 32 1 (n - 1)+		where n = ECC.ecc_n $ ECC.common_curve c+	calculatePublic cv sn =+		ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv+	calculateShared cv sn pp =+		let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x++getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g)+getRangedInteger b mn mx g = let+	(n, g') = first (either error id . B.decode) $ cprgGenerate b g in+	if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g'++secp256r1 :: ECC.Curve+secp256r1 = ECC.getCurveByName ECC.SEC_p256r1++finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished+finishedHash s = (Finished `liftM`) $ do+	fh <- HM.finishedHash s+	case s of+		HM.Client -> HM.setClientFinished fh+		HM.Server -> HM.setServerFinished fh+	return fh++instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where+	type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g+	type DebugLevel (HM.TlsHandle h g) = DebugLevel h+	hlPut = HM.hlPut_+	hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .)+		. HM.tlsGet__ . (, undefined)+	hlGetLine = ($) <$> checkAppData <*> HM.tGetLine+	hlGetContent = ($) <$> checkAppData <*> HM.tGetContent+	hlDebug = HM.hlDebug_+	hlClose = HM.hlClose_++checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g ->+	HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString+checkAppData t m = m >>= \cp -> case cp of+	(HM.CTAppData, ad) -> return ad+	(HM.CTAlert, "\SOH\NUL") -> do+		_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL"+		E.throwError "TlsHandle.checkAppData: EOF"+	(HM.CTHandshake, hs) -> do+		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n"+		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack+			. (++ "\n") $ show hs+		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack+			. (++ "\n") $ show (B.decode hs :: Either String Handshake)+		return ""+	_ -> do	_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10"+		E.throwError "TlsHandle.checkAppData: not application data"++hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->+	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString+hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh+	. (, undefined)++hlGetLineRn_, hlGetContentRn_ :: (HM.ValidateHandle h, CPRG g) =>+	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString+hlGetLineRn_ rh = ($) <$> checkAppData <*> HM.tGetLine_ rh+hlGetContentRn_ rh = ($) <$> checkAppData <*> HM.tGetContent_ rh++hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->+	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString+hlGetRn rn t n = do+	bf <- HM.getAdBuf t+	if BS.length bf >= n+	then do	let (ret, rest) = BS.splitAt n bf+		HM.setAdBuf t rest+		return ret+	else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf)++hlGetLineRn :: (HM.ValidateHandle h, CPRG g) =>+	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g ->+	HM.TlsM h g BS.ByteString+hlGetLineRn rn t = do+	bf <- HM.getAdBuf t+	if '\n' `BSC.elem` bf || '\r' `BSC.elem` bf+	then do	let (ret, rest) = splitOneLine bf+		HM.setAdBuf t $ BS.tail rest+		return ret+	else (bf `BS.append`) `liftM` hlGetLineRn_ rn t++splitOneLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)+splitOneLine bs = case BSC.span (/= '\r') bs of+	(_, "") -> second BS.tail $ BSC.span (/= '\n') bs+	(l, ls) -> (l, dropRet ls)++dropRet :: BS.ByteString -> BS.ByteString+dropRet bs = case BSC.uncons bs of+	Just ('\r', bs') -> case BSC.uncons bs' of+		Just ('\n', bs'') -> bs''+		_ -> bs'+	_ -> bs++hlGetContentRn :: (HM.ValidateHandle h, CPRG g) =>+	(HM.TlsHandle h g -> HM.TlsM h g ()) ->+	HM.TlsHandle h g -> HM.TlsM h g BS.ByteString+hlGetContentRn rn t = do+	bf <- HM.getAdBuf t+	if BS.null bf+	then hlGetContentRn_ rn t+	else do	HM.setAdBuf t ""+		return bf++flushAppData :: (HandleLike h, CPRG g) => HM.HandshakeM h g Bool+flushAppData = uncurry (>>) . (HM.pushAdBufH *** return) =<< HM.flushAppData_++isEcdsaKey :: HM.CertSecretKey -> Bool+isEcdsaKey (HM.EcdsaKey _) = True+isEcdsaKey _ = False++isRsaKey :: HM.CertSecretKey -> Bool+isRsaKey (HM.RsaKey _) = True+isRsaKey _ = False++eRenegoInfo :: Extension -> Maybe BS.ByteString+eRenegoInfo (ERenegoInfo ri) = Just ri+eRenegoInfo _ = Nothing

@@ -3,5 +3,7 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -data CertSecretKey = RsaKey RSA.PrivateKey | EcdsaKey ECDSA.PrivateKey+data CertSecretKey+	= RsaKey { rsaKey :: RSA.PrivateKey }+	| EcdsaKey { ecdsaKey :: ECDSA.PrivateKey } 	deriving Show

@@ -17,7 +17,7 @@ import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.HashSignAlgorithm (HashAlg, SignAlg)+import Network.PeyoTLS.HSAlg (HashAlg, SignAlg)  instance B.Bytable X509.CertificateChain where 	decode = B.evalBytableM B.parse

@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.PeyoTLS.CipherSuite (-	CipherSuite(..), KeyExchange(..), BulkEncryption(..)) where+	CipherSuite(..), KeyEx(..), BulkEnc(..)) where  import Control.Arrow (first, (***)) import Data.Word (Word8)@@ -11,12 +11,12 @@ import qualified Codec.Bytable.BigEndian as B  data CipherSuite-	= CipherSuite KeyExchange BulkEncryption-	| TLS_EMPTY_RENEGOTIATION_INFO_SCSV+	= CipherSuite KeyEx BulkEnc+	| EMPTY_RENEGOTIATION_INFO 	| CipherSuiteRaw Word8 Word8 	deriving (Show, Read, Eq) -data KeyExchange+data KeyEx 	= RSA 	| DHE_RSA 	| ECDHE_RSA@@ -25,7 +25,7 @@ 	| KE_NULL 	deriving (Show, Read, Eq) -data BulkEncryption+data BulkEnc 	= AES_128_CBC_SHA 	| AES_128_CBC_SHA256 --	| CAMELLIA_128_CBC_SHA@@ -48,7 +48,7 @@ 		(0x00, 0x3c) -> CipherSuite RSA AES_128_CBC_SHA256 --		(0x00, 0x45) -> CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA 		(0x00, 0x67) -> CipherSuite DHE_RSA AES_128_CBC_SHA256-		(0x00, 0xff) -> TLS_EMPTY_RENEGOTIATION_INFO_SCSV+		(0x00, 0xff) -> EMPTY_RENEGOTIATION_INFO 		(0xc0, 0x09) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA 		(0xc0, 0x13) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA 		(0xc0, 0x23) -> CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256@@ -64,7 +64,7 @@ encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c" -- encodeCipherSuite (CipherSuite DHE_RSA CAMELLIA_128_CBC_SHA) = "\x00\x45" encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67"-encodeCipherSuite TLS_EMPTY_RENEGOTIATION_INFO_SCSV = "\x00\xff"+encodeCipherSuite EMPTY_RENEGOTIATION_INFO = "\x00\xff" encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09" encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13" encodeCipherSuite (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23"

@@ -1,14 +1,15 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,-	UndecidableInstances, PackageImports, ScopedTypeVariables #-}+	PackageImports, ScopedTypeVariables #-}  module Network.PeyoTLS.Client ( 	PeyotlsM, PeyotlsHandleC, 	TlsM, TlsHandleC, 	run, open, renegotiate, names,-	CipherSuite(..), KeyExchange(..), BulkEncryption(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..), 	ValidateHandle(..), CertSecretKey ) where  import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first) import Control.Monad (when, unless, liftM) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..))@@ -32,25 +33,23 @@ import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.HandshakeBase as HB-import Network.PeyoTLS.HandshakeBase ( flushAppData,-	Extension(..), getClientFinished, Finished(..),-	getInitSet, setInitSet,-	setClientFinished, getClientFinished,-	setServerFinished, getServerFinished,-	PeyotlsM, PeyotlsHandle,+import qualified Network.PeyoTLS.Base as HB+import Network.PeyoTLS.Base ( flushAppData,+	Extension(..), getClientFinished,+	getSettings, setSettings,+	getClientFinished, getServerFinished,+	PeyotlsM, 	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, 		CertSecretKey(..), 		withRandom, randomByteString, 	TlsHandle, 		readHandshake, getChangeCipherSpec,-		readHandshakeNoHash, 		writeHandshake, putChangeCipherSpec, 	ValidateHandle(..), handshakeValidate, 	ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..), 	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..), HashAlg(..), SignAlg(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..), HashAlg(..), SignAlg(..), 		setCipherSuite, 	CertificateRequest(..), ClientCertificateType(..), 	ClientKeyExchange(..), Epms(..),@@ -69,32 +68,37 @@ 	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> 	TlsM h g (TlsHandleC h g) open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do-	setInitSet (cscl, crts, Just ca)+	setSettings (cscl, rcrt, ecrt, Just ca) 	cr <- clientHello cscl-	handshake crts ca cr+	handshake rcrt ecrt ca cr+	where+	rcrt = first rsaKey <$> find (HB.isRsaKey . fst) crts+	ecrt = first ecdsaKey <$> find (HB.isEcdsaKey . fst) crts  renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleC h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do-	(cscl, crts, Just ca) <- getInitSet+	(cscl, rcrt, ecrt, Just ca) <- getSettings 	cr <- clientHello cscl-	(ret, ne) <- flushAppData-	bf <- HB.getAdBufH-	HB.setAdBufH $ bf `BS.append` ret-	when ne $ handshake crts ca cr+	HB.debug "critical" ("CLIENT HASH AFTER CLIENTHELLO" :: String)+	HB.debug "critical" =<< handshakeHash+	ne <- flushAppData+	when ne $ handshake rcrt ecrt ca cr  rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do-	(cscl, crts, Just ca) <- getInitSet+	(cscl, rcrt, ecrt, Just ca) <- getSettings 	cr <- clientHello cscl-	handshake crts ca cr-	return ()+	handshake rcrt ecrt ca cr  handshake :: (ValidateHandle h, CPRG g) =>-	[(CertSecretKey, X509.CertificateChain)] ->+	Maybe (RSA.PrivateKey, X509.CertificateChain) ->+	Maybe (ECDSA.PrivateKey, X509.CertificateChain) -> 	X509.CertificateStore -> BS.ByteString -> HandshakeM h g ()-handshake crts ca cr = do+handshake rcrt ecrt ca cr = do 	(sr, cs@(CipherSuite ke _)) <- serverHello 	setCipherSuite cs+	HB.debug "critical" ("CLIENT HASH AFTER SERVERHELLO" :: String)+	HB.debug "critical" =<< handshakeHash 	case ke of 		RSA -> rsaHandshake cr sr crts ca 		DHE_RSA -> dheHandshake dhType cr sr crts ca@@ -104,6 +108,12 @@ 	where 	dhType :: DH.Params; dhType = undefined 	curveType :: ECC.Curve; curveType = undefined+	crts = case (rcrt, ecrt) of+		(Just (rsk, rcc), Just (esk, ecc)) -> [+			(RsaKey rsk, rcc), (EcdsaKey esk, ecc)]+		(Just (rsk, rcc), _) -> [(RsaKey rsk, rcc)]+		(_, Just (esk, ecc)) -> [(EcdsaKey esk, ecc)]+		_ -> []  getRenegoInfo :: Maybe [Extension] -> Maybe BS.ByteString getRenegoInfo Nothing = Nothing@@ -117,7 +127,7 @@ 	cr <- randomByteString 32 	cf <- getClientFinished 	writeHandshake . ClientHello (3, 3) cr (SessionId "") cscl-		[CompressionMethodNull] $ Just [ERenegoInfo cf]+		[CompMethodNull] $ Just [ERenegoInfo cf] 	return cr  serverHello :: (HandleLike h, CPRG g) =>@@ -271,12 +281,10 @@ 			writeHandshake $ digitallySigned sk (pubKey sk c) hs 		_ -> return () 	putChangeCipherSpec >> flushCipherSuite Write-	fc@(Finished fcb) <- finishedHash Client+	fc <- finishedHash Client 	writeHandshake fc-	setClientFinished fcb 	getChangeCipherSpec >> flushCipherSuite Read-	fs@(Finished fsb) <- finishedHash Server-	setServerFinished fsb+	fs <- finishedHash Server 	(fs ==) `liftM` readHandshake >>= flip unless 		(E.throwError "TlsClient.finishHandshake: finished hash failure") 	where@@ -312,42 +320,13 @@ newtype TlsHandleC h g = TlsHandleC { tlsHandleC :: TlsHandle h g }  instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleC h g) where-	type HandleMonad (TlsHandleC h g) = HandleMonad (TlsHandle h g)-	type DebugLevel (TlsHandleC h g) = DebugLevel (TlsHandle h g)+	type HandleMonad (TlsHandleC h g) = TlsM h g+	type DebugLevel (TlsHandleC h g) = DebugLevel h 	hlPut (TlsHandleC t) = hlPut t-	hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleC-	hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleC-	hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleC+	hlGet = hlGetRn rehandshake . tlsHandleC+	hlGetLine = hlGetLineRn rehandshake . tlsHandleC+	hlGetContent = hlGetContentRn rehandshake . tlsHandleC 	hlDebug (TlsHandleC t) = hlDebug t 	hlClose (TlsHandleC t) = hlClose t--hlGet_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleC h g -> Int -> TlsM h g BS.ByteString-hlGet_ (TlsHandleC t) n = do-	bf <- HB.getAdBuf t-	if (BS.length bf >= 0)-	then do	let (ret, rest) = BS.splitAt n bf-		HB.setAdBuf t rest-		return ret-	else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf)--hlGetLine_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleC h g -> TlsM h g BS.ByteString-hlGetLine_ (TlsHandleC t) = do-	bf <- HB.getAdBuf t-	if (10 `BS.elem` bf)-	then do	let (ret, rest) = BS.span (/= 10) bf-		HB.setAdBuf t $ BS.tail rest-		return ret-	else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t--hlGetContent_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleC h g -> TlsM h g BS.ByteString-hlGetContent_ (TlsHandleC t) = do-	bf <- HB.getAdBuf t-	if BS.null bf-	then hlGetContentRn rehandshake t-	else do	HB.setAdBuf t ""-		return bf  type PeyotlsHandleC = TlsHandleC Handle SystemRNG

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-}++module Network.PeyoTLS.Crypto (+	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where++import Prelude hiding (splitAt, take)++import Control.Arrow (first)+import Data.Bits (xor)+import Data.Word (Word8, Word16, Word64)+import "crypto-random" Crypto.Random (CPRG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Cipher.AES as AES++import qualified Codec.Bytable.BigEndian as B++makeKeys :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString ->+	(BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString)+makeKeys kl cr sr pms = let+	kls = [kl, kl, 16, 16]+	ms = take 48 . prf pms $ BS.concat ["master secret", cr, sr]+	ems = prf ms $ BS.concat ["key expansion", sr, cr]+	[cwmk, swmk, cwk, swk] = divide kls ems in+	(ms, cwmk, swmk, cwk, swk)+	where+	divide [] _ = []+	divide (n : ns) bs+		| BSL.null bs = []+		| otherwise = let (x, bs') = splitAt n bs in x : divide ns bs'++prf :: BS.ByteString -> BS.ByteString -> BSL.ByteString+prf sk sd = BSL.fromChunks . ph $ hm sk sd+	where+	hm = hmac SHA256.hash 64+	ph a = hm sk (a `BS.append` sd) : ph (hm sk a)++hmac :: (BS.ByteString -> BS.ByteString) -> Int ->+	BS.ByteString -> BS.ByteString -> BS.ByteString+hmac hs bls sk =+	hs . BS.append (BS.map (0x5c `xor`) k) .+	hs . BS.append (BS.map (0x36 `xor`) k)+	where+	k = pd $ if BS.length sk > bls then hs sk else sk+	pd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0++type Hash = BS.ByteString -> BS.ByteString++hashSha1, hashSha256 :: (Hash, Int)+hashSha1 = (SHA1.hash, 20)+hashSha256 = (SHA256.hash, 32)++encrypt :: CPRG g => (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 ->+	BS.ByteString -> BS.ByteString -> g -> (BS.ByteString, g)+encrypt (hs, _) k mk sn p m g = (, g') $+	iv `BS.append` AES.encryptCBC (AES.initAES k) iv (pln `BS.append` pd)+	where+	(iv, g') = cprgGenerate 16 g+	pln = m `BS.append` calcMac hs mk sn (p `BS.append` B.addLen w16 m)+	l = 16 - (BS.length pln + 1) `mod` 16+	pd = BS.replicate (l + 1) $ fromIntegral l++decrypt :: (Hash, Int) ->+	BS.ByteString -> BS.ByteString -> Word64 ->+	BS.ByteString -> BS.ByteString -> Either String BS.ByteString+decrypt (hs, ml) k mk sn p enc = if rm == em then Right b else Left $ if BS.null enc+	then "CryptoTools.decrypt: enc is null\n"+	else "CryptoTools.decrypt: bad MAC:" +++		"\n\tsn: " ++ show sn +++		"\n\tplain: " ++ BSC.unpack pln +++		"\n\tExpected: " ++ BSC.unpack em +++		"\n\tRecieved: " ++ BSC.unpack rm +++		"\n\tml: " ++ show ml ++ "\n"+	where+	pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc+	up = BS.take (BS.length pln - fromIntegral (myLast "decrypt" pln) - 1) pln+	(b, rm) = BS.splitAt (BS.length up - ml) up+	em = calcMac hs mk sn $ p `BS.append` B.addLen w16 b++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"++myLast :: String -> BS.ByteString -> Word8+myLast msg "" = error msg+myLast _ bs = BS.last bs++take :: Int -> BSL.ByteString -> BS.ByteString+take = (fst .) . splitAt++splitAt :: Int -> BSL.ByteString -> (BS.ByteString, BSL.ByteString)+splitAt n = first BSL.toStrict . BSL.splitAt (fromIntegral n)++w16 :: Word16; w16 = undefined

@@ -1,102 +0,0 @@-{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-}--module Network.PeyoTLS.CryptoTools (-	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash) where--import Prelude hiding (splitAt, take)--import Control.Arrow (first)-import Data.Bits (xor)-import Data.Word (Word8, Word16, Word64)-import "crypto-random" Crypto.Random (CPRG, cprgGenerate)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as BSL-import qualified Crypto.Hash.SHA1 as SHA1-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.Cipher.AES as AES--import qualified Codec.Bytable.BigEndian as B--makeKeys :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString ->-	(BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString, BS.ByteString)-makeKeys kl cr sr pms = let-	kls = [kl, kl, 16, 16]-	ms = take 48 . prf pms $ BS.concat ["master secret", cr, sr]-	ems = prf ms $ BS.concat ["key expansion", sr, cr]-	[cwmk, swmk, cwk, swk] = divide kls ems in-	(ms, cwmk, swmk, cwk, swk)-	where-	divide [] _ = []-	divide (n : ns) bs-		| BSL.null bs = []-		| otherwise = let (x, bs') = splitAt n bs in x : divide ns bs'--prf :: BS.ByteString -> BS.ByteString -> BSL.ByteString-prf sk sd = BSL.fromChunks . ph $ hm sk sd-	where-	hm = hmac SHA256.hash 64-	ph a = hm sk (a `BS.append` sd) : ph (hm sk a)--hmac :: (BS.ByteString -> BS.ByteString) -> Int ->-	BS.ByteString -> BS.ByteString -> BS.ByteString-hmac hs bls sk =-	hs . BS.append (BS.map (0x5c `xor`) k) .-	hs . BS.append (BS.map (0x36 `xor`) k)-	where-	k = pd $ if BS.length sk > bls then hs sk else sk-	pd bs = bs `BS.append` BS.replicate (bls - BS.length bs) 0--type Hash = BS.ByteString -> BS.ByteString--hashSha1, hashSha256 :: (Hash, Int)-hashSha1 = (SHA1.hash, 20)-hashSha256 = (SHA256.hash, 32)--encrypt :: CPRG g => (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 ->-	BS.ByteString -> BS.ByteString -> g -> (BS.ByteString, g)-encrypt (hs, _) k mk sn p m g = (, g') $-	iv `BS.append` AES.encryptCBC (AES.initAES k) iv (pln `BS.append` pd)-	where-	(iv, g') = cprgGenerate 16 g-	pln = m `BS.append` calcMac hs mk sn (p `BS.append` B.addLen w16 m)-	l = 16 - (BS.length pln + 1) `mod` 16-	pd = BS.replicate (l + 1) $ fromIntegral l--decrypt :: (Hash, Int) ->-	BS.ByteString -> BS.ByteString -> Word64 ->-	BS.ByteString -> BS.ByteString -> Either String BS.ByteString-decrypt (hs, ml) k mk sn p enc = if rm == em then Right b else Left $ if BS.null enc-	then "CryptoTools.decrypt: enc is null\n"-	else "CryptoTools.decrypt: bad MAC:" ++-		"\n\tsn: " ++ show sn ++-		"\n\tplain: " ++ BSC.unpack pln ++-		"\n\tExpected: " ++ BSC.unpack em ++-		"\n\tRecieved: " ++ BSC.unpack rm ++-		"\n\tml: " ++ show ml ++ "\n"-	where-	pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc-	up = BS.take (BS.length pln - fromIntegral (myLast "decrypt" pln) - 1) pln-	(b, rm) = BS.splitAt (BS.length up - ml) up-	em = calcMac hs mk sn $ p `BS.append` B.addLen w16 b--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"--myLast :: String -> BS.ByteString -> Word8-myLast msg "" = error msg-myLast _ bs = BS.last bs--take :: Int -> BSL.ByteString -> BS.ByteString-take = (fst .) . splitAt--splitAt :: Int -> BSL.ByteString -> (BS.ByteString, BSL.ByteString)-splitAt n = first BSL.toStrict . BSL.splitAt (fromIntegral n)--w16 :: Word16; w16 = undefined

@@ -12,7 +12,7 @@ import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC -import Network.PeyoTLS.HashSignAlgorithm(HashAlg(..), SignAlg(..))+import Network.PeyoTLS.HSAlg(HashAlg(..), SignAlg(..))  data Extension 	= ESName [ServerName]

@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.HSAlg (SignAlg(..), HashAlg(..)) where++import Data.Word (Word8)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++data HashAlg = Sha1 | Sha224 | Sha256 | Sha384 | Sha512 | HARaw Word8+	deriving Show++instance B.Bytable HashAlg where+	encode Sha1   = "\x02"+	encode Sha224 = "\x03"+	encode Sha256 = "\x04"+	encode Sha384 = "\x05"+	encode Sha512 = "\x06"+	encode (HARaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[ha] -> Right $ case ha of+			2 -> Sha1  ; 3 -> Sha224; 4 -> Sha256+			5 -> Sha384; 6 -> Sha512; _ -> HARaw ha+		_ -> Left "HashSignAlgorithm: Bytable.decode"++instance B.Parsable HashAlg where+	parse = B.take 1++data SignAlg = Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq)++instance B.Bytable SignAlg where+	encode Rsa = "\x01"+	encode Dsa = "\x02"+	encode Ecdsa = "\x03"+	encode (SARaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[sa] -> Right $ case sa of+			1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa+		_ -> Left "Type.decodeSA"++instance B.Parsable SignAlg where+	parse = B.take 1

@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}++module Network.PeyoTLS.Handle (+	TlsM, Alert(..), AlertLevel(..), AlertDesc(..),+		run, withRandom, randomByteString,+	TlsHandle(..), 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,++	getInitSetT, setInitSetT,+	InitialSettings,++	resetSequenceNumber,+	tlsGet_,+	flushAppData,++	getAdBufT, setAdBufT,+	CertSecretKey(..),+	) where++import Prelude hiding (read)++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 Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+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,+	InitialSettings,+	getInitSet, setInitSet,+	CertSecretKey(..),+	)+import qualified Network.PeyoTLS.Crypto as CT (+	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash )++data TlsHandle h g = TlsHandle {+	clientId :: PartnerId,+	tlsHandle :: h,+	names :: [String] }+	deriving Show++type HandleHash h g = (TlsHandle h g, SHA256.Ctx)++data Side = Server | Client deriving (Show, Eq)++run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a+run m g = do+	ret <- (`evalTlsM` 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 (TlsHandle h g)+newHandle h = do+	s <- get+	let (i, s') = newPartnerId s+	put s'+	return TlsHandle {+		clientId = i, tlsHandle = h, names = [] }++getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType+getContentType t = do+	ct <- fst `liftM` getBuf (clientId t)+	(\gt -> case ct of CTNull -> gt; _ -> return ct) $ do+		(ct', bf) <- getWholeWithCt t+		setBuf (clientId t) (ct', bf)+		return ct'++flushAppData :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> TlsM h g (BS.ByteString, Bool)+flushAppData t = do+	ct <- getContentType t+	case ct of+		CTAppData -> do+			(_, ad) <- tGetContent t+			(bs, b) <- flushAppData t+			return (ad `BS.append` bs, b)+--			liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t+		CTAlert -> do+			((_, a), _) <- tlsGet True (t, undefined) 2+			case a of+				"\1\0" -> return ("", False)+				_ -> throwError "flushAppData"+		_ -> return ("", True)++tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g ->+	Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g)+tlsGet b hh@(t, _) n = do+	r@(ct, bs) <- buffered t n+	(r ,) `liftM` case (ct, b, bs) of+		(CTHandshake, _, "\0") -> return hh+		(CTHandshake, True, _)+			| "\0\0\0\0" `BS.isPrefixOf` bs ->+				updateHash hh $ BS.drop 4 bs+			| otherwise -> updateHash hh bs+		_ -> return hh++tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	HandleHash h g -> Int ->+	TlsM h g ((ContentType, BS.ByteString), HandleHash h g)+tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n++buffered :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered t n = do+	(ct, b) <- getBuf $ clientId 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 $+			"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')+		second (b `BS.append`) `liftM` buffered t rl++buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered_ 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+			if rl <= 0+			then splitRetBuf t n ct b+			else do (ct', b') <- getWholeWithCt t+				unless (ct' == ct) . throwError . strMsg $+					"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++splitRetBuf :: HandleLike h =>+	TlsHandle h g -> Int -> ContentType -> BS.ByteString ->+	TlsM h g (ContentType, BS.ByteString)+splitRetBuf t n ct b = do+	let (ret, b') = BS.splitAt n b+	setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')+	return (ct, ret)++getWholeWithCt :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+getWholeWithCt t = do+	flush t+	ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1+	[_vmj, _vmn] <- BS.unpack `liftM` read t 2+	e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2+	when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null"+	p <- decrypt t ct e+	thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct+	thlDebug (tlsHandle t) "medium" . BSC.pack . (++  "\n") . show $ BS.head p+	thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p+	return (ct, p)++read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString+read t n = do+	r <- thlGet (tlsHandle t) n+	unless (BS.length r == n) . throwError . strMsg $+		"TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n+	return r++decrypt :: HandleLike h =>+	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+decrypt t ct e = do+	ks <- getKeys $ clientId t+	decrypt_ t ks ct e++decrypt_ :: HandleLike h => TlsHandle h g ->+	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+decrypt_ _ Keys{ kReadCS = CipherSuite _ 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+	hs <- case be of+		AES_128_CBC_SHA -> return CT.hashSha1+		AES_128_CBC_SHA256 -> return CT.hashSha256+		_ -> throwError "TlsHandle.decrypt: not implement bulk encryption"+	either (throwError . strMsg) return $+		CT.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+	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+		(CTHandshake, True) -> updateHash hh p+		_ -> return hh++flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()+flush t = do+	(bct, bp) <- getWBuf $ clientId t+	setWBuf (clientId t) (CTNull, "")+	unless (bct == CTNull) $ do+		e <- encrypt t bct bp+		thlPut (tlsHandle t) $ BS.concat [+			B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ]++encrypt :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+encrypt t ct p = do+	ks <- getKeys $ clientId t+	encrypt_ t ks ct p++encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g ->+	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p+encrypt_ t ks ct p = do+	let	CipherSuite _ be = kWriteCS ks+		wk = kWriteKey ks+		mk = kWriteMacKey ks+	sn <- updateSequenceNumber t Write+	hs <- case be of+		AES_128_CBC_SHA -> return CT.hashSha1+		AES_128_CBC_SHA256 -> return CT.hashSha256+		_ -> throwError "TlsHandle.encrypt: not implemented bulk encryption"+	withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p++updateHash ::+	HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g)+updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs)++updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64+updateSequenceNumber t rw = do+	ks <- getKeys $ clientId t+	(sn, cs) <- case rw of+		Read -> (, kReadCS ks) `liftM` getReadSn (clientId t)+		Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t)+	case cs of+		CipherSuite _ BE_NULL -> return ()+		_ -> case rw of+			Read -> succReadSn $ clientId t+			Write -> succWriteSn $ clientId t+	return sn++resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g ()+resetSequenceNumber t rw = case rw of+	Read -> resetReadSn $ clientId t+	Write -> resetWriteSn $ clientId t++generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite ->+	BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys+generateKeys t p cs cr sr pms = do+	let CipherSuite _ be = cs+	kl <- case be of+		AES_128_CBC_SHA -> return 20+		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+	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++flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g ()+flushCipherSuiteSt p = case p of+	Read -> flushCipherSuiteRead+	Write -> flushCipherSuiteWrite++debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g ()+debugCipherSuite t a = do+	k <- getKeys $ clientId t+	thlDebug (tlsHandle t) "high" . BSC.pack+		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50+		. show $ 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) => TlsHandle h g -> BS.ByteString -> TlsM h g ()+hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined)++hlDebug_ :: HandleLike h =>+	TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g ()+hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l++hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()+hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >>+	flush t >> thlClose (tlsHandle t)++tGetLine :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+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++tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetLine_ rn t = do+	ct <- getContentType t+	case ct of+		CTHandshake -> rn t >> tGetLine_ rn t+		_ -> do	(bct, bp) <- getBuf $ clientId t+			case splitLine bp of+				Just (l, ls) -> do+					setBuf (clientId t) (bct, ls)+					return (bct, l)+				_ -> do	cp <- getWholeWithCt t+					setBuf (clientId t) cp+					second (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+	(True, _) -> let+		(l, ls) = BSC.span (/= '\r') bs+		Just ('\r', ls') = BSC.uncons ls in+		case BSC.uncons ls' of+			Just ('\n', ls'') -> Just (l, ls'')+			_ -> Just (l, ls')+	(_, True) -> let+		(l, ls) = BSC.span (/= '\n') bs+		Just ('\n', ls') = BSC.uncons ls in Just (l, ls')+	_ -> Nothing++tGetContent :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetContent t = do+	bcp@(_, bp) <- getBuf $ clientId t+	if BS.null bp then getWholeWithCt t else+		setBuf (clientId t) (CTNull, BS.empty) >> return bcp++getClientFinishedT, getServerFinishedT ::+	HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+getClientFinishedT = getClientFinished . clientId+getServerFinishedT = getServerFinished . clientId++setClientFinishedT, setServerFinishedT ::+	HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()+setClientFinishedT = setClientFinished . clientId+setServerFinishedT = setServerFinished . clientId++getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings+getInitSetT = getInitSet . clientId++setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g ()+setInitSetT = setInitSet . clientId++getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+getAdBufT = getAdBuf . clientId++setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()+setAdBufT = setAdBuf . clientId

@@ -1,337 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports,-	TupleSections #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.PeyoTLS.HandshakeBase ( Extension(..),-	PeyotlsM, PeyotlsHandle,-	debug, generateKs, blindSign, CertSecretKey(..),-	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM,-	HM.withRandom, HM.randomByteString,-	HM.TlsHandle, HM.names,-		readHandshake, getChangeCipherSpec,-		readHandshakeNoHash,-		writeHandshake, putChangeCipherSpec,-		writeHandshakeNoHash,-	HM.ValidateHandle(..), HM.handshakeValidate,-	HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..),-	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	ServerHelloDone(..),-	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..), HashAlg(..), SignAlg(..),-		HM.setCipherSuite,-	CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..),-	ClientKeyExchange(..), Epms(..),-		HM.generateKeys,-		HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite,-	DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite,-	HM.Side(..), HM.RW(..), finishedHash,-	DhParam(..), dh3072Modp, secp256r1, HM.throwError,-	HM.getClientFinished, HM.setClientFinished,-	HM.getServerFinished, HM.setServerFinished,-	Finished(..),-	HM.ContentType(CTAlert, CTHandshake, CTAppData),-	Handshake(..),-	HM.tlsHandle,-	hlGetRn, hlGetLineRn, hlGetContentRn,--	HM.getInitSet, HM.setInitSet,-	HM.flushAppData,-	HM.getAdBuf,-	HM.setAdBuf,-	HM.getAdBufH,-	HM.setAdBufH,-	) where--import Control.Applicative-import Control.Arrow (first)-import Control.Monad (liftM, ap)-import "monads-tf" Control.Monad.State (gets, lift)-import qualified "monads-tf" Control.Monad.Error as E-import Data.Word (Word8)-import Data.HandleLike (HandleLike(..))-import System.IO (Handle)-import Numeric (readHex)-import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-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.Hash.SHA1 as SHA1-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.Prim as RSA-import qualified Crypto.Types.PubKey.DH as DH-import qualified Crypto.PubKey.DH as DH-import qualified Crypto.Types.PubKey.ECC as ECC-import qualified Crypto.PubKey.ECC.Prim as ECC-import qualified Crypto.Types.PubKey.ECDSA as ECDSA--import Network.PeyoTLS.HandshakeType ( Extension(..),-	Handshake(..), HandshakeItem(..),-	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..),-	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),-		SignAlg(..), HashAlg(..),-	ServerHelloDone(..), ClientKeyExchange(..), Epms(..),-	DigitallySigned(..), Finished(..) )-import qualified Network.PeyoTLS.HandshakeMonad as HM (-	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM,-	withRandom, randomByteString,-	ValidateHandle(..), handshakeValidate,-	TlsHandle(..), ContentType(..),-		names,-		setCipherSuite, flushCipherSuite, debugCipherSuite,-		tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash,-		generateKeys, encryptRsa, decryptRsa, rsaPadding,-	Alert(..), AlertLevel(..), AlertDesc(..),-	Side(..), RW(..), handshakeHash, finishedHash, throwError,-	hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_,-	tGetLine_, tGetContent_, tlsGet__,-	hlDebug_, hlClose_,-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,-	resetSequenceNumber,--	getInitSet, setInitSet,-	flushAppData,-	getAdBuf,-	setAdBuf,-	getAdBufH,-	setAdBufH,-	)-import Network.PeyoTLS.Ecdsa (blindSign, generateKs)--import Network.PeyoTLS.CertSecretKey--type PeyotlsM = HM.TlsM Handle SystemRNG-type PeyotlsHandle = HM.TlsHandle Handle SystemRNG--debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g ()-debug p x = do-	h <- gets $ HM.tlsHandle . fst-	lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x--readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi-readHandshake = do-	cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType-	hs <- case cnt of-		CHandshake HHelloRequest -> readHandshake-		CHandshake hs -> return hs-		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage $-			"HandshakeBase.readHandshake: not handshake: " ++ show cnt-	case fromHandshake hs of-		Just i -> return i-		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage $-			"HandshakeBase.readHandshake: type mismatch " ++ show hs--readHandshakeNoHash :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi-readHandshakeNoHash = do-	cnt <- readContent (HM.tlsGet False) =<< HM.tlsGetContentType-	hs <- case cnt of-		CHandshake hs -> return hs-		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage $-			"HandshakeBase.readHandshake: not handshake: " ++ show cnt-	case fromHandshake hs of-		Just i -> return i-		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage $-			"HandshakeBase.readHandshake: type mismatch " ++ show hs--writeHandshake, writeHandshakeNoHash ::-	(HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g ()-writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake-writeHandshakeNoHash =-	uncurry HM.tlsPutNoHash . encodeContent . CHandshake . toHandshake--data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show--instance B.Bytable ChangeCipherSpec where-	decode bs = case BS.unpack bs of-		[1] -> Right ChangeCipherSpec-		[w] -> Right $ ChangeCipherSpecRaw w-		_ -> Left "HandshakeBase: ChangeCipherSpec.decode"-	encode ChangeCipherSpec = BS.pack [1]-	encode (ChangeCipherSpecRaw w) = BS.pack [w]--getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()-getChangeCipherSpec = do-	cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType-	case cnt of-		CCCSpec ChangeCipherSpec -> return ()-		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage $-			"HandshakeBase.getChangeCipherSpec: " ++-			"not change cipher spec: " ++-			show cnt-	HM.resetSequenceNumber HM.Read--putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()-putChangeCipherSpec = do-	uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec-	HM.resetSequenceNumber HM.Write--data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake-	deriving Show--readContent :: Monad m => (Int -> m BS.ByteString) -> HM.ContentType -> m Content-readContent rd HM.CTCCSpec = (CCCSpec . either error id . B.decode) `liftM` rd 1-readContent rd HM.CTAlert = ((\[al, ad] -> CAlert al ad) . BS.unpack) `liftM` rd 2-readContent rd HM.CTHandshake = CHandshake `liftM` do-	(t, len) <- (,) `liftM` rd 1 `ap` rd 3-	body <- rd . either error id $ B.decode len-	return . either error id . B.decode $ BS.concat [t, len, body]-readContent _ _ = undefined--encodeContent :: Content -> (HM.ContentType, BS.ByteString)-encodeContent (CCCSpec ccs) = (HM.CTCCSpec, B.encode ccs)-encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad])-encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss)--class SecretKey sk where-	type Blinder sk-	generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)-	sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString-	signatureAlgorithm :: sk -> SignAlg--instance SecretKey RSA.PrivateKey where-	type Blinder RSA.PrivateKey = RSA.Blinder-	generateBlinder sk rng =-		RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk-	sign hs bl sk bs = let-		(h, oid) = first ($ bs) $ case hs of-			Sha1 -> (SHA1.hash,-				ASN1.OID [1, 3, 14, 3, 2, 26])-			Sha256 -> (SHA256.hash,-				ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])-			_ -> error $ "HandshakeBase: " ++-				"not implemented bulk encryption type"-		a = [ASN1.Start ASN1.Sequence,-			ASN1.Start ASN1.Sequence,-				oid, ASN1.Null, ASN1.End ASN1.Sequence,-			ASN1.OctetString h, ASN1.End ASN1.Sequence]-		b = ASN1.encodeASN1' ASN1.DER a-		pd = BS.concat [ "\x00\x01",-			BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ]-		ps = RSA.public_size $ RSA.private_pub sk in-		RSA.dp (Just bl) sk pd-	signatureAlgorithm _ = Rsa--instance SecretKey ECDSA.PrivateKey where-	type Blinder ECDSA.PrivateKey = Integer-	generateBlinder _ rng = let-		(Right bl, rng') = first B.decode $ cprgGenerate 32 rng in-		(bl, rng')-	sign ha bl sk = B.encode .-		(($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)-		where-		(hs, bls) = case ha of-			Sha1 -> (SHA1.hash, 64)-			Sha256 -> (SHA256.hash, 64)-			_ -> error $ "HandshakeBase: " ++-				"not implemented bulk encryption type"-		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk-		x = ECDSA.private_d sk-	signatureAlgorithm _ = Ecdsa--class DhParam b where-	type Secret b-	type Public b-	generateSecret :: CPRG g => b -> g -> (Secret b, g)-	calculatePublic :: b -> Secret b -> Public b-	calculateShared :: b -> Secret b -> Public b -> BS.ByteString--instance DhParam DH.Params where-	type Secret DH.Params = DH.PrivateNumber-	type Public DH.Params = DH.PublicNumber-	generateSecret = flip DH.generatePrivate-	calculatePublic = DH.calculatePublic-	calculateShared ps sn pn = B.encode .-		(\(DH.SharedKey s) -> s) $ DH.getShared ps sn pn--dh3072Modp :: DH.Params-dh3072Modp = DH.Params p 2-	where [(p, "")] = readHex $-		"ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++-		"29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++-		"ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++-		"e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++-		"ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++-		"c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++-		"83655d23dca3ad961c62f356208552bb9ed529077096966d" ++-		"670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++-		"e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++-		"de2bcbf6955817183995497cea956ae515d2261898fa0510" ++-		"15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++-		"ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++-		"abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++-		"f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++-		"bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++-		"43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"--instance DhParam ECC.Curve where-	type Secret ECC.Curve = Integer-	type Public ECC.Curve = ECC.Point-	generateSecret c = getRangedInteger 32 1 (n - 1)-		where n = ECC.ecc_n $ ECC.common_curve c-	calculatePublic cv sn =-		ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv-	calculateShared cv sn pp =-		let ECC.Point x _ = ECC.pointMul cv sn pp in B.encode x--getRangedInteger :: CPRG g => Int -> Integer -> Integer -> g -> (Integer, g)-getRangedInteger b mn mx g = let-	(n, g') = first (either error id . B.decode) $ cprgGenerate b g in-	if mn <= n && n <= mx then (n, g') else getRangedInteger b mn mx g'--secp256r1 :: ECC.Curve-secp256r1 = ECC.getCurveByName ECC.SEC_p256r1--finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished-finishedHash = (Finished `liftM`) . HM.finishedHash--instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where-	type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g-	type DebugLevel (HM.TlsHandle h g) = DebugLevel h-	hlPut = HM.hlPut_-	hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .)-		. HM.tlsGet__ . (, undefined)-	hlGetLine = ($) <$> checkAppData <*> HM.tGetLine-	hlGetContent = ($) <$> checkAppData <*> HM.tGetContent-	hlDebug = HM.hlDebug_-	hlClose = HM.hlClose_--checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g ->-	HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString-checkAppData t m = m >>= \cp -> case cp of-	(HM.CTAppData, ad) -> return ad-	(HM.CTAlert, "\SOH\NUL") -> do-		_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL"-		E.throwError "TlsHandle.checkAppData: EOF"-	(HM.CTHandshake, hs) -> do-		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n"-		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack-			. (++ "\n") $ show hs-		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack-			. (++ "\n") $ show (B.decode hs :: Either String Handshake)-		return ""-	_ -> do	_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10"-		E.throwError "TlsHandle.checkAppData: not application data"--hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->-	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString-hlGetRn rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh-	. (, undefined)--hlGetLineRn, hlGetContentRn :: (HM.ValidateHandle h, CPRG g) =>-	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString-hlGetLineRn rh = ($) <$> checkAppData <*> HM.tGetLine_ rh-hlGetContentRn rh = ($) <$> checkAppData <*> HM.tGetContent_ rh

@@ -1,237 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-}--module Network.PeyoTLS.HandshakeMonad (-	TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM,-	withRandom, randomByteString,-	ValidateHandle(..), handshakeValidate,-	TH.TlsHandle(..), TH.ContentType(..),-		setCipherSuite, flushCipherSuite, debugCipherSuite,-		tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash,-		generateKeys, encryptRsa, decryptRsa, rsaPadding,-	TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..),-	TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError,-	TH.hlPut_, TH.hlDebug_, TH.hlClose_,-	TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__,-	tGetLine_, tGetContent_,-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,--	resetSequenceNumber,--	getInitSet, setInitSet,-	flushAppData,--	getAdBuf, setAdBuf,-	getAdBufH, setAdBufH,-	) where--import Prelude hiding (read)--import Control.Applicative-import qualified Data.ASN1.Types as ASN1-import Control.Arrow (first)-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)-import Data.HandleLike (HandleLike(..))-import System.IO (Handle)-import "crypto-random" Crypto.Random (CPRG)--import qualified Data.ByteString as BS-import qualified Data.X509 as X509-import qualified Data.X509.Validation as X509-import qualified Data.X509.CertificateStore as X509-import qualified Crypto.Hash.SHA256 as SHA256-import qualified Crypto.PubKey.HashDescr as HD-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as RSA--import qualified Network.PeyoTLS.TlsHandle as TH (-	TlsM, Alert(..), AlertLevel(..), AlertDesc(..),-		run, withRandom, randomByteString,-	TlsHandle(..), 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,--	getInitSetT, setInitSetT, InitialSettings,-	tlsGet_,-	flushAppData,-	getAdBufT,-	setAdBufT,-	)--resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g ()-resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw--tlsGet_ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g -> TH.TlsM h g ()) ->-	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))-tlsGet_ = TH.tlsGet_--tlsGet__ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))-tlsGet__ = TH.tlsGet True--tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g -> TH.TlsM h g ()) ->-	TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)-tGetLine_ = TH.tGetLine_--flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)-flushAppData = gets fst >>= lift . TH.flushAppData--tGetContent_ rn t = do-	ct <- TH.getContentType t-	case ct of-		TH.CTHandshake -> rn t >> tGetContent_ rn t-		_ -> TH.tGetContent t--tlsPut_ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx)-tlsPut_ = TH.tlsPut True--throwError :: HandleLike h =>-	TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a-throwError al ad m = E.throwError $ TH.Alert al ad m--type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g)--execHandshakeM :: HandleLike h =>-	h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g)-execHandshakeM h =-	liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT--rerunHandshakeM ::-	HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a-rerunHandshakeM t hm = evalStateT hm (t, 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]--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 }--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--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 $ last c }-	lift . lift . lift $ validate (TH.tlsHandle t) cs cc--setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()-setCipherSuite cs = do-	t <- gets fst-	lift $ TH.setCipherSuiteSt (TH.clientId t) cs--flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g ()-flushCipherSuite p = do-	t <- gets fst-	lift $ TH.flushCipherSuiteSt p (TH.clientId t)--debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()-debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m--tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType-tlsGetContentType = gets fst >>= lift . TH.getContentType--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--tlsPut, tlsPutNoHash :: (HandleLike h, CPRG g) =>-	TH.ContentType -> BS.ByteString -> HandshakeM h g ()-tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut True t ct bs) >>= put-tlsPutNoHash ct bs = get >>= lift . (\t -> TH.tlsPut False t ct bs) >>= put--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--encryptRsa :: (HandleLike h, CPRG g) =>-	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString-encryptRsa pk p = either (E.throwError . strMsg . show) return =<<-	withRandom (\g -> RSA.encrypt g pk p)--decryptRsa :: (HandleLike h, CPRG g) =>-	RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString-decryptRsa sk e = either (E.throwError . strMsg . show) return =<<-	withRandom (\g -> RSA.decryptSafer g sk e)--rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString-rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $-			HD.digestToASN1 HD.hashDescrSHA256 bs of-		Right pd -> pd; Left m -> error $ show m--handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString-handshakeHash = get >>= lift . TH.handshakeHash--finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString-finishedHash p = get >>= lift . flip TH.finishedHash p--getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString-getClientFinished = gets fst >>= lift . TH.getClientFinishedT-getServerFinished = gets fst >>= lift . TH.getServerFinishedT--setClientFinished, setServerFinished ::-	HandleLike h => BS.ByteString -> HandshakeM h g ()-setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf-setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf--getInitSet :: HandleLike h => HandshakeM h g TH.InitialSettings-getInitSet = gets fst >>= lift . TH.getInitSetT--setInitSet :: HandleLike h => TH.InitialSettings -> HandshakeM h g ()-setInitSet is = gets fst >>= lift . flip TH.setInitSetT is---- getAdBuf :: HandleLike h => HandshakeM h g BS.ByteString-getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString-getAdBuf = TH.getAdBufT -- = gets fst >>= lift . TH.getAdBufT---- setAdBuf :: HandleLike h => BS.ByteString -> HandshakeM h g ()-setAdBuf :: HandleLike h =>-	TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g ()-setAdBuf = TH.setAdBufT -- bs = gets fst >>= lift . flip TH.setAdBufT bs--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

@@ -1,240 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.PeyoTLS.HandshakeType ( Extension(..),-	Handshake(..), HandshakeItem(..),-	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..),-	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),-		SignAlg(..), HashAlg(..),-	ServerHelloDone(..), ClientKeyExchange(..), Epms(..),-	DigitallySigned(..), Finished(..) ) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad (unless)-import Data.Word (Word8, Word16)-import Data.Word.Word24 (Word24)--import qualified Data.ByteString as BS-import qualified Data.X509 as X509-import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.PubKey.DH as DH-import qualified Crypto.Types.PubKey.ECC as ECC--import Network.PeyoTLS.Hello ( Extension(..),-	ClientHello(..), ServerHello(..), SessionId(..),-	CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	CompressionMethod(..), HashAlg(..), SignAlg(..) )-import Network.PeyoTLS.Certificate (-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),-	ClientKeyExchange(..), DigitallySigned(..) )--data Handshake-	= HHelloRequest-	| HClientHello ClientHello           | HServerHello ServerHello-	| HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString-	| HCertificateReq CertificateRequest | HServerHelloDone-	| HCertVerify DigitallySigned        | HClientKeyEx ClientKeyExchange-	| HFinished BS.ByteString            | HRaw Type BS.ByteString-	deriving Show--instance B.Bytable Handshake where-	decode = B.evalBytableM B.parse; encode = encodeH--instance B.Parsable Handshake where-	parse = do-		t <- B.take 1-		len <- B.take 3-		case t of-			THelloRequest -> do-				unless (len == 0) $ fail "parse Handshake"-				return HHelloRequest-			TClientHello -> HClientHello <$> B.take len-			TServerHello -> HServerHello <$> B.take len-			TCertificate -> HCertificate <$> B.take len-			TServerKeyEx -> HServerKeyEx <$> B.take len-			TCertificateReq -> HCertificateReq <$> B.take len-			TServerHelloDone -> let 0 = len in return HServerHelloDone-			TCertVerify -> HCertVerify <$> B.take len-			TClientKeyEx -> HClientKeyEx <$> B.take len-			TFinished -> HFinished <$> B.take len-			_ -> HRaw t <$> B.take len--encodeH :: Handshake -> BS.ByteString-encodeH HHelloRequest = encodeH $ HRaw THelloRequest ""-encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch-encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh-encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts-encodeH (HServerKeyEx ske) = encodeH $ HRaw TServerKeyEx ske-encodeH (HCertificateReq cr) = encodeH . HRaw TCertificateReq $ B.encode cr-encodeH HServerHelloDone = encodeH $ HRaw TServerHelloDone ""-encodeH (HCertVerify ds) = encodeH . HRaw TCertVerify $ B.encode ds-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--class HandshakeItem hi where-	fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake--instance HandshakeItem Handshake where-	fromHandshake = Just; toHandshake = id--instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where-	fromHandshake hs = let-		l = fromHandshake hs-		r = fromHandshake hs in maybe (Right <$> r) (Just . Left) l-	toHandshake (Left l) = toHandshake l-	toHandshake (Right r) = toHandshake r--instance HandshakeItem ClientHello where-	fromHandshake (HClientHello ch) = Just ch-	fromHandshake _ = Nothing-	toHandshake = HClientHello--instance HandshakeItem ServerHello where-	fromHandshake (HServerHello sh) = Just sh-	fromHandshake _ = Nothing-	toHandshake = HServerHello--instance HandshakeItem X509.CertificateChain where-	fromHandshake (HCertificate cc) = Just cc-	fromHandshake _ = Nothing-	toHandshake = HCertificate--data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString-	HashAlg SignAlg BS.ByteString deriving Show--data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber-	HashAlg SignAlg BS.ByteString deriving Show--data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point-	HashAlg SignAlg BS.ByteString deriving Show--instance HandshakeItem ServerKeyExchange where-	fromHandshake = undefined-	toHandshake = HServerKeyEx . B.encode--instance HandshakeItem ServerKeyExDhe where-	toHandshake = HServerKeyEx . B.encode-	fromHandshake (HServerKeyEx ske) =-		either (const Nothing) Just $ B.decode ske-	fromHandshake _ = Nothing--instance HandshakeItem ServerKeyExEcdhe where-	toHandshake = HServerKeyEx . B.encode-	fromHandshake (HServerKeyEx ske) =-		either (const Nothing) Just $ B.decode ske-	fromHandshake _ = Nothing--instance B.Bytable ServerKeyExchange where-	decode = undefined-	encode (ServerKeyEx ps pv ha sa sn) = BS.concat [-		ps, pv, B.encode ha, B.encode sa,-		B.addLen (undefined :: Word16) sn ]--instance B.Bytable ServerKeyExDhe where-	encode (ServerKeyExDhe ps pv ha sa sn) = BS.concat [-		B.encode ps, B.encode pv, B.encode ha, B.encode sa,-		B.addLen (undefined :: Word16) sn ]-	decode = B.evalBytableM B.parse--instance B.Bytable ServerKeyExEcdhe where-	encode (ServerKeyExEcdhe cv pnt ha sa sn) = BS.concat [-		B.encode cv, B.encode pnt, B.encode ha, B.encode sa,-		B.addLen (undefined :: Word16) sn ]-	decode = B.evalBytableM B.parse--instance B.Parsable ServerKeyExDhe where-	parse = do-		ps <- B.parse-		pv <- B.parse-		(ha, sa, sn) <- hasasn-		return $ ServerKeyExDhe ps pv ha sa sn--instance B.Parsable ServerKeyExEcdhe where-	parse = do-		cv <- B.parse-		pnt <- B.parse-		(ha, sa, sn) <- hasasn-		return $ ServerKeyExEcdhe cv pnt ha sa sn--hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString)-hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2)--instance HandshakeItem CertificateRequest where-	fromHandshake (HCertificateReq cr) = Just cr-	fromHandshake _ = Nothing-	toHandshake = HCertificateReq--instance HandshakeItem ServerHelloDone where-	fromHandshake HServerHelloDone = Just ServerHelloDone-	fromHandshake _ = Nothing-	toHandshake _ = HServerHelloDone--instance HandshakeItem DigitallySigned where-	fromHandshake (HCertVerify ds) = Just ds-	fromHandshake _ = Nothing-	toHandshake = HCertVerify--instance HandshakeItem ClientKeyExchange where-	fromHandshake (HClientKeyEx cke) = Just cke-	fromHandshake _ = Nothing-	toHandshake = HClientKeyEx--data Epms = Epms BS.ByteString--instance HandshakeItem Epms where-	fromHandshake (HClientKeyEx cke) = ckeToEpms cke-	fromHandshake _ = Nothing-	toHandshake = HClientKeyEx . epmsToCke--ckeToEpms :: ClientKeyExchange -> Maybe Epms-ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of-	Right (e, "") -> Just $ Epms e-	_ -> Nothing--epmsToCke :: Epms -> ClientKeyExchange-epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms--data Finished = Finished BS.ByteString deriving (Show, Eq)--instance HandshakeItem Finished where-	fromHandshake (HFinished f) = Just $ Finished f-	fromHandshake _ = Nothing-	toHandshake (Finished f) = HFinished f--data ServerHelloDone = ServerHelloDone deriving Show--data Type-	= THelloRequest | TClientHello | TServerHello-	| TCertificate  | TServerKeyEx | TCertificateReq | TServerHelloDone-	| TCertVerify   | TClientKeyEx | TFinished       | TRaw Word8-	deriving Show--instance B.Bytable Type where-	decode bs = case BS.unpack bs of-		[0] -> Right THelloRequest-		[1] -> Right TClientHello-		[2] -> Right TServerHello-		[11] -> Right TCertificate-		[12] -> Right TServerKeyEx-		[13] -> Right TCertificateReq-		[14] -> Right TServerHelloDone-		[15] -> Right TCertVerify-		[16] -> Right TClientKeyEx-		[20] -> Right TFinished-		[ht] -> Right $ TRaw ht-		_ -> Left "Handshake.decodeT"-	encode THelloRequest = BS.pack [0]-	encode TClientHello = BS.pack [1]-	encode TServerHello = BS.pack [2]-	encode TCertificate = BS.pack [11]-	encode TServerKeyEx = BS.pack [12]-	encode TCertificateReq = BS.pack [13]-	encode TServerHelloDone = BS.pack [14]-	encode TCertVerify = BS.pack [15]-	encode TClientKeyEx = BS.pack [16]-	encode TFinished = BS.pack [20]-	encode (TRaw w) = BS.pack [w]

@@ -1,42 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.PeyoTLS.HashSignAlgorithm (SignAlg(..), HashAlg(..)) where--import Data.Word (Word8)--import qualified Data.ByteString as BS-import qualified Codec.Bytable.BigEndian as B--data HashAlg = Sha1 | Sha224 | Sha256 | Sha384 | Sha512 | HARaw Word8-	deriving Show--instance B.Bytable HashAlg where-	encode Sha1   = "\x02"-	encode Sha224 = "\x03"-	encode Sha256 = "\x04"-	encode Sha384 = "\x05"-	encode Sha512 = "\x06"-	encode (HARaw w) = BS.pack [w]-	decode bs = case BS.unpack bs of-		[ha] -> Right $ case ha of-			2 -> Sha1  ; 3 -> Sha224; 4 -> Sha256-			5 -> Sha384; 6 -> Sha512; _ -> HARaw ha-		_ -> Left "HashSignAlgorithm: Bytable.decode"--instance B.Parsable HashAlg where-	parse = B.take 1--data SignAlg = Rsa | Dsa | Ecdsa | SARaw Word8 deriving (Show, Eq)--instance B.Bytable SignAlg where-	encode Rsa = "\x01"-	encode Dsa = "\x02"-	encode Ecdsa = "\x03"-	encode (SARaw w) = BS.pack [w]-	decode bs = case BS.unpack bs of-		[sa] -> Right $ case sa of-			1 -> Rsa; 2 -> Dsa; 3 -> Ecdsa; _ -> SARaw sa-		_ -> Left "Type.decodeSA"--instance B.Parsable SignAlg where-	parse = B.take 1

@@ -2,8 +2,8 @@  module Network.PeyoTLS.Hello ( Extension(..), 	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..), 		SignAlg(..), HashAlg(..) ) where  import Control.Applicative ((<$>), (<*>))@@ -15,11 +15,11 @@  import Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..)) import Network.PeyoTLS.CipherSuite (-	CipherSuite(..), KeyExchange(..), BulkEncryption(..))+	CipherSuite(..), KeyEx(..), BulkEnc(..))  data ClientHello 	= ClientHello (Word8, Word8) BS.ByteString SessionId-		[CipherSuite] [CompressionMethod] (Maybe [Extension])+		[CipherSuite] [CompMethod] (Maybe [Extension]) 	| ClientHelloRaw BS.ByteString 	deriving Show @@ -46,7 +46,7 @@  data ServerHello 	= ServerHello (Word8, Word8) BS.ByteString SessionId-		CipherSuite CompressionMethod (Maybe [Extension])+		CipherSuite CompMethod (Maybe [Extension]) 	| ServerHelloRaw BS.ByteString 	deriving Show @@ -71,17 +71,17 @@ 	maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mes ] encodeSh (ServerHelloRaw sh) = sh -data CompressionMethod = CompressionMethodNull | CompressionMethodRaw Word8+data CompMethod = CompMethodNull | CompMethodRaw Word8 	deriving (Show, Eq) -instance B.Bytable CompressionMethod where+instance B.Bytable CompMethod where 	decode bs = case BS.unpack bs of 		[cm] -> Right $ case cm of-			0 -> CompressionMethodNull-			_ -> CompressionMethodRaw cm+			0 -> CompMethodNull+			_ -> CompMethodRaw cm 		_ -> Left "Hello.decodeCm"-	encode CompressionMethodNull = "\0"-	encode (CompressionMethodRaw cm) = BS.pack [cm]+	encode CompMethodNull = "\0"+	encode (CompMethodRaw cm) = BS.pack [cm]  data SessionId = SessionId BS.ByteString 

@@ -0,0 +1,137 @@+{-# LANGUAGE PackageImports #-}++module Network.PeyoTLS.Monad (+	TlsM, evalTlsM, S.initState,+		thlGet, thlPut, thlClose, thlDebug, thlError,+		withRandom, randomByteString,+		getBuf, setBuf, getWBuf, setWBuf,+		getAdBuf, setAdBuf,+		getReadSn, getWriteSn, succReadSn, succWriteSn,+		resetReadSn, resetWriteSn,+		getCipherSuiteSt, setCipherSuiteSt,+		flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,+		getInitSet, setInitSet, S.InitialSettings,+	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,+	S.CertSecretKey(..),+	) where++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 Data.Word (Word64)+import Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG, cprgGenerate)++import qualified Data.ByteString as BS++import qualified Network.PeyoTLS.State as S (+	HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,+	ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	randomGen, setRandomGen,+	setBuf, getBuf, setWBuf, getWBuf,+	setAdBuf, getAdBuf,+	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN,+	getCipherSuite, setCipherSuite,+	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,+	getInitSet, setInitSet,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,++	InitialSettings,+	CertSecretKey(..),+	)++type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h))++evalTlsM :: HandleLike h => +	TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a)+evalTlsM = evalStateT . runErrorT++getBuf, getWBuf ::  HandleLike h =>+	S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString)+getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf++getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getAdBuf = gets . S.getAdBuf++setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setAdBuf = (modify .) . S.setAdBuf++setBuf, setWBuf :: HandleLike h =>+	S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()+setBuf = (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++succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()+succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN++resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()+resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN++getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite+getCipherSuiteSt = gets . S.getCipherSuite++setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()+setCipherSuiteSt = (modify .) . S.setCipherSuite++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.InitialSettings+getInitSet = gets . S.getInitSet++setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g ()+setInitSet = (modify .) . S.setInitSet++getClientFinished, getServerFinished ::+	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getClientFinished = gets . S.getClientFinished+getServerFinished = gets . S.getServerFinished++setClientFinished, setServerFinished ::+	HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setClientFinished = (modify .) . S.setClientFinished+setServerFinished = (modify .) . S.setServerFinished++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++thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString+thlGet = ((lift . lift) .) . hlGet++thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()+thlPut = ((lift . lift) .) . hlPut++thlClose :: HandleLike h => h -> TlsM h g ()+thlClose = lift . lift . hlClose++thlDebug :: HandleLike h =>+	h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()+thlDebug = (((lift . lift) .) .) . hlDebug++thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a+thlError = ((lift . lift) .) . hlError

@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-}++module Network.PeyoTLS.Run (+	TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM,+	withRandom, randomByteString,+	ValidateHandle(..), handshakeValidate,+	TH.TlsHandle(..), TH.ContentType(..),+		getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+		tlsGetContentType, tlsGet, tlsPut, tlsPutNH,+		generateKeys, encryptRsa, decryptRsa, rsaPadding,+	TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..),+	TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError,+	TH.hlPut_, TH.hlDebug_, TH.hlClose_,+	TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__,+	tGetLine_, tGetContent_,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,++	resetSequenceNumber,++	getSettings, setSettings,+	flushAppData_,++	getAdBuf, setAdBuf,+	pushAdBufH,++	TH.CertSecretKey(..)+	) where++import Prelude hiding (read)++import Control.Applicative+import qualified Data.ASN1.Types as ASN1+import Control.Arrow (first)+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)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509+import qualified Data.X509.CertificateStore as X509+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.PubKey.HashDescr as HD+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA++import qualified Network.PeyoTLS.Handle as TH (+	TlsM, Alert(..), AlertLevel(..), AlertDesc(..),+		run, withRandom, randomByteString,+	TlsHandle(..), 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,++	getInitSetT, setInitSetT, InitialSettings,+	tlsGet_,+	flushAppData,+	getAdBufT,+	setAdBufT,++	CertSecretKey(..),+	)++resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g ()+resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw++tlsGet_ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g -> TH.TlsM h g ()) ->+	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))+tlsGet_ = TH.tlsGet_++tlsGet__ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))+tlsGet__ = TH.tlsGet True++tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g -> TH.TlsM h g ()) ->+	TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)+tGetLine_ = TH.tGetLine_++flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)+flushAppData_ = gets fst >>= lift . TH.flushAppData++tGetContent_ rn t = do+	ct <- TH.getContentType t+	case ct of+		TH.CTHandshake -> rn t >> tGetContent_ rn t+		_ -> TH.tGetContent t++tlsPut_ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx)+tlsPut_ = TH.tlsPut True++throwError :: HandleLike h =>+	TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a+throwError al ad m = E.throwError $ TH.Alert al ad m++type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g)++execHandshakeM :: HandleLike h =>+	h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g)+execHandshakeM h =+	liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT++rerunHandshakeM ::+	HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a+rerunHandshakeM t hm = evalStateT hm (t, 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]++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 }++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++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 $ last c }+	lift . lift . lift $ validate (TH.tlsHandle t) cs cc++setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()+setCipherSuite cs = do+	t <- gets fst+	lift $ TH.setCipherSuiteSt (TH.clientId t) cs++getCipherSuite :: HandleLike h => HandshakeM h g TH.CipherSuite+getCipherSuite = do+	t <- gets fst+	lift . TH.getCipherSuiteSt $ TH.clientId t++flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g ()+flushCipherSuite p = do+	t <- gets fst+	lift $ TH.flushCipherSuiteSt p (TH.clientId t)++debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()+debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m++tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType+tlsGetContentType = gets fst >>= lift . TH.getContentType++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++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++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++encryptRsa :: (HandleLike h, CPRG g) =>+	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString+encryptRsa pk p = either (E.throwError . strMsg . show) return =<<+	withRandom (\g -> RSA.encrypt g pk p)++decryptRsa :: (HandleLike h, CPRG g) =>+	RSA.PrivateKey -> BS.ByteString -> HandshakeM h g BS.ByteString+decryptRsa sk e = either (E.throwError . strMsg . show) return =<<+	withRandom (\g -> RSA.decryptSafer g sk e)++rsaPadding :: RSA.PublicKey -> BS.ByteString -> BS.ByteString+rsaPadding pk bs = case RSA.padSignature (RSA.public_size pk) $+			HD.digestToASN1 HD.hashDescrSHA256 bs of+		Right pd -> pd; Left m -> error $ show m++handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString+handshakeHash = get >>= lift . TH.handshakeHash++finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString+finishedHash p = get >>= lift . flip TH.finishedHash p++getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString+getClientFinished = gets fst >>= lift . TH.getClientFinishedT+getServerFinished = gets fst >>= lift . TH.getServerFinishedT++setClientFinished, setServerFinished ::+	HandleLike h => BS.ByteString -> HandshakeM h g ()+setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf+setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf++getSettings :: HandleLike h => HandshakeM h g TH.InitialSettings+getSettings = gets fst >>= lift . TH.getInitSetT++setSettings :: HandleLike h => TH.InitialSettings -> HandshakeM h g ()+setSettings is = gets fst >>= lift . flip TH.setInitSetT is++getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString+getAdBuf = TH.getAdBufT++setAdBuf :: HandleLike h =>+	TH.TlsHandle 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++pushAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g ()+pushAdBufH bs = do+	bf <- getAdBufH+	setAdBufH $ bf `BS.append` bs

@@ -1,21 +1,21 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, FlexibleContexts,-	UndecidableInstances, PackageImports #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports, TupleSections #-}  module Network.PeyoTLS.Server (-	PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS,-	run, open, renegotiate, names,-	CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	ValidateHandle(..), CertSecretKey ) where+	PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS, run, open, renegotiate, names,+	CipherSuite(..), KeyEx(..), BulkEnc(..), ValidateHandle(..), CertSecretKey+	) where +import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first) import Control.Monad (when, unless, liftM, ap)+import "monads-tf" Control.Monad.Error (catchError)+import Data.Maybe (listToMaybe, mapMaybe) import Data.List (find) import Data.Word (Word8) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG, SystemRNG) -import qualified "monads-tf" Control.Monad.Error as E-import qualified "monads-tf" Control.Monad.Error.Class as E import qualified Data.ByteString as BS import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509@@ -27,147 +27,168 @@ import qualified Crypto.Types.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.HandshakeBase as HB-import Network.PeyoTLS.HandshakeBase (+import qualified Network.PeyoTLS.Base as HB (names)+import Network.PeyoTLS.Base ( 	PeyotlsM, TlsM, run, 	HandshakeM, execHandshakeM, rerunHandshakeM,-		setCipherSuite, withRandom, randomByteString,+		throwError, debug, debugCipherSuite,+		withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate,-	TlsHandle, CertSecretKey(..),+	TlsHandle, CertSecretKey(..), isRsaKey, isEcdsaKey, 		readHandshake, getChangeCipherSpec, 		writeHandshake, putChangeCipherSpec,-		writeHandshakeNoHash,+		writeHandshakeNH, 	AlertLevel(..), AlertDesc(..), 	ClientHello(..), ServerHello(..), SessionId(..), Extension(..),-		CipherSuite(..), KeyExchange(..), BulkEncryption(..),-		CompressionMethod(..), HashAlg(..), SignAlg(..),-		getClientFinished, setClientFinished,-		getServerFinished, setServerFinished,+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..), HashAlg(..), SignAlg(..),+		getCipherSuite, setCipherSuite,+		getClientFinished, getServerFinished, 	ServerKeyExchange(..), 	certificateRequest, ClientCertificateType(..), SecretKey(..), 	ServerHelloDone(..), 	ClientKeyExchange(..), Epms(..),-		generateKeys, decryptRsa, rsaPadding, debugCipherSuite,-	DigitallySigned(..), handshakeHash, flushCipherSuite,-	Finished(..), Side(..), RW(..), finishedHash,-	DhParam(..), dh3072Modp, secp256r1, throwError,+		generateKeys, decryptRsa, rsaPadding,+	DigitallySigned(..), handshakeHash,+	RW(..), flushCipherSuite,+	Side(..), finishedHash,+	DhParam(..), dh3072Modp, secp256r1, -	hlGetRn, hlGetLineRn, hlGetContentRn, debug )+	Handshake(HHelloReq), eRenegoInfo, getSettings, setSettings, flushAppData,+	hlGetRn, hlGetLineRn, hlGetContentRn )  type PeyotlsHandleS = TlsHandleS Handle SystemRNG +newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g } deriving Show++instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where+	type HandleMonad (TlsHandleS h g) = TlsM h g+	type DebugLevel (TlsHandleS h g) = DebugLevel h+	hlPut (TlsHandleS t) = hlPut t+	hlGet = hlGetRn rehandshake . tlsHandleS+	hlGetLine = hlGetLineRn rehandshake . tlsHandleS+	hlGetContent = hlGetContentRn rehandshake . tlsHandleS+	hlDebug (TlsHandleS t) = hlDebug t+	hlClose (TlsHandleS t) = hlClose t++type Version = (Word8, Word8)+type Settings = (+	[CipherSuite],+	Maybe (RSA.PrivateKey, X509.CertificateChain),+	Maybe (ECDSA.PrivateKey, X509.CertificateChain),+	Maybe X509.CertificateStore )++version :: Version+version = (3, 3)+ names :: TlsHandleS h g -> [String] names = HB.names . tlsHandleS -open :: (ValidateHandle h, CPRG g) =>-	h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] ->+open :: (ValidateHandle h, CPRG g) => h ->+	[CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> 	Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g)-open h cssv crts mcs = (TlsHandleS `liftM`) . execHandshakeM h $ do-	HB.setInitSet (cssv, crts, mcs)-	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv-	succeed cs cr cv crts mcs rn+open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $+	((>>) <$> setSettings <*> handshake) (cssv',+		first rsaKey <$> find (isRsaKey . fst) crts,+		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs )+	where+	cssv' = filter iscs $ case find (isEcdsaKey . fst) crts of+		Just _ -> cssv+		_ -> flip filter cssv $ \cs -> case cs of+			CipherSuite ECDHE_ECDSA _ -> False+			_ -> True+	iscs (CipherSuiteRaw _ _) = False+	iscs EMPTY_RENEGOTIATION_INFO = False+	iscs _ = True -renegotiate ::-	(ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g ()-renegotiate (TlsHandleS t) = rerunHandshakeM t $ do-	writeHandshakeNoHash HB.HHelloRequest-	(ret, ne) <- HB.flushAppData-	bf <- HB.getAdBufH-	HB.setAdBufH $ bf `BS.append` ret-	when ne $ handshake+renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g ()+renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >>+		flushAppData >>= flip when (handshake =<< getSettings)  rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()-rehandshake t = rerunHandshakeM t handshake+rehandshake t = rerunHandshakeM t $ handshake =<< getSettings -handshake :: (ValidateHandle h, CPRG g) => HandshakeM h g ()-handshake = do-	(cssv, crts, mcs) <- HB.getInitSet-	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv-	succeed cs cr cv crts mcs rn+handshake :: (ValidateHandle h, CPRG g) => Settings -> HandshakeM h g ()+handshake (cssv, rcrt, ecrt, mcs) = do+	(ke, be, cr, cv, rn) <- clientHello cssv+	sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) rn+	ha <- case be of+		AES_128_CBC_SHA -> return Sha1+		AES_128_CBC_SHA256 -> return Sha256+		_ -> throwError ALFatal ADInternalError $+			pre ++ "not implemented bulk encryption type"+	mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, rcrt, ecrt) of+		(RSA, Just (rsk, _), _) -> rsaKeyExchange rsk cv+		(DHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha dh3072Modp rsk+		(ECDHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha secp256r1 rsk+		(ECDHE_ECDSA, _, Just (esk, _)) -> dhKeyExchange ha secp256r1 esk+		_ -> \_ _ -> throwError ALFatal ADInternalError $+			pre ++ "no implemented key exchange type or " +++				"no applicable certificate files"+	maybe (return ()) certificateVerify mpk+	getChangeCipherSpec >> flushCipherSuite Read+	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok ->+		unless ok . throwError ALFatal ADDecryptError $+			pre ++ "wrong finished hash"+	putChangeCipherSpec >> flushCipherSuite Write+	writeHandshake =<< finishedHash Server+	where pre = "Network.PeyoTLS.Server.handshake: " -clientHello :: (HandleLike h, CPRG g) =>-	[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool)+clientHello :: (HandleLike h, CPRG g) => [CipherSuite] ->+	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version, Bool) clientHello cssv = do-	cf0 <- getClientFinished-	ch@(ClientHello cv cr _sid cscl cms me) <- readHandshake-	let (cf, rn) = case me of-		Nothing -> ("", False)-		Just e -> case getRenegoInfo cscl e of-			Nothing -> ("", False)-			Just c -> (c, True)-	debug "medium" ch-	unless (cf == cf0) $ E.throwError "clientHello"-	chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn)+	ClientHello cv cr _sid cscl cms me <- readHandshake+	checkRenegotiation cscl me+	unless (cv >= version) . throwError ALFatal ADProtocolVersion $+		pre ++ "client version should 3.3 or more"+	unless (CompMethodNull `elem` cms) . throwError ALFatal ADDecodeError $+		pre ++ "compression method NULL must be supported"+	(ke, be) <- case find (`elem` cscl) cssv of+		Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b)+		_ -> throwError ALFatal ADHandshakeFailure $+			pre ++ "no acceptable set of security parameters"+	return (ke, be, cr, cv, True)+	where pre = "Network.PeyoTLS.Server.clientHello: "++checkRenegotiation ::+	HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()+checkRenegotiation cscl me = do+	case mcf of+		Just cf -> (cf ==) `liftM` getClientFinished >>= \ok -> unless ok .+			throwError ALFatal ADHandshakeFailure $+				pre ++ "bad renegotiation"+		_ -> throwError ALFatal ADInsufficientSecurity $+			pre ++ "require secure renegotiation" 	where-	merge sv cl = case find (`elem` cl) sv of-		Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA-	chk cv _css cms-		| cv < version = throwError ALFatal ADProtocolVersion $-			pmsg ++ "client version should 3.3 or more"-		| CompressionMethodNull `notElem` cms =-			throwError ALFatal ADDecodeError $-				pmsg ++ "compression method NULL must be supported"-		| otherwise = return ()-		where pmsg = "TlsServer.clientHello: "-	getRenegoInfo [] [] = Nothing-	getRenegoInfo (TLS_EMPTY_RENEGOTIATION_INFO_SCSV : _) _ = Just ""-	getRenegoInfo (_ : css) e = getRenegoInfo css e-	getRenegoInfo [] (ERenegoInfo rn : _) = Just rn-	getRenegoInfo [] (_ : es) = getRenegoInfo [] es+	pre = "Network.PeyoTLS.Server.checkRenegotiation: "+	mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of+		(True, _) -> Just ""+		(_, Just e) -> listToMaybe $ mapMaybe eRenegoInfo e+		(_, _) -> Nothing -serverHello :: (HandleLike h, CPRG g) => CipherSuite ->-	X509.CertificateChain -> X509.CertificateChain -> Bool ->+serverHello :: (HandleLike h, CPRG g) =>+	Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> Bool -> 	HandshakeM h g BS.ByteString-serverHello cs@(CipherSuite ke _) rcc ecc rn = do+serverHello rcc ecc rn = do+	cs@(CipherSuite ke _) <- getCipherSuite 	sr <- randomByteString 32 	cf <- getClientFinished 	sf <- getServerFinished 	writeHandshake . ServerHello-		version sr (SessionId "") cs CompressionMethodNull $ if rn+		version sr (SessionId "") cs CompMethodNull $ if rn 			then Just [ERenegoInfo $ cf `BS.append` sf] 			else Nothing-	writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc+	debug "critical" ("SERVER HASH AFTER SERVERHELLO" :: String)+	debug "critical" =<< handshakeHash+	writeHandshake $ case (ke, rcc, ecc) of+		(ECDHE_ECDSA, _, Just c) -> c+		(_, Just c, _) -> c+		_ -> error "serverHello" 	return sr-serverHello _ _ _ _ = E.throwError "TlsServer.serverHello: never occur"--succeed :: (ValidateHandle h, CPRG g) => CipherSuite -> BS.ByteString ->-	Version -> [(CertSecretKey, X509.CertificateChain)] ->-	Maybe X509.CertificateStore -> Bool -> HandshakeM h g ()-succeed cs@(CipherSuite ke be) cr cv crts mcs rn = do-	sr <- serverHello cs rcc ecc rn-	setCipherSuite cs-	ha <- case be of-		AES_128_CBC_SHA -> return Sha1-		AES_128_CBC_SHA256 -> return Sha256-		_ -> E.throwError-			"TlsServer.succeed: not implemented bulk encryption type"-	mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of-		RSA -> rsaKeyExchange rsk cv-		DHE_RSA -> dhKeyExchange ha dh3072Modp rsk-		ECDHE_RSA -> dhKeyExchange ha secp256r1 rsk-		ECDHE_ECDSA -> dhKeyExchange ha secp256r1 esk-		_ -> \_ _ -> E.throwError-			"TlsServer.succeed: not implemented key exchange type"-	maybe (return ()) certificateVerify mpk-	getChangeCipherSpec >> flushCipherSuite Read-	cf@(Finished cfb) <- finishedHash Client-	rcf <- readHandshake-	debug "low" ("client finished hash" :: String)-	debug "low" cf-	debug "low" rcf-	unless (cf == rcf) $ throwError ALFatal ADDecryptError-		"TlsServer.succeed: wrong finished hash"-	setClientFinished cfb-	putChangeCipherSpec >> flushCipherSuite Write-	sf@(Finished sfb) <- finishedHash Server-	setServerFinished sfb-	writeHandshake sf-	where-	Just (RsaKey rsk, rcc) = find isRsa crts-	Just (EcdsaKey esk, ecc) = find isEcdsa crts-	isRsa (RsaKey _, _) = True-	isRsa _ = False-succeed _ _ _ _ _ _ = E.throwError "Network.PeyoTLS.Server.succeed: not implemented"+	{-+serverHello _ _ _ _ = throwError ALFatal ADInternalError+	"Network.PeyoTLS.Server.serverHello: never occur"+	-}  rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> 	(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->@@ -208,6 +229,8 @@ 	flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest 		[CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)] 	writeHandshake ServerHelloDone+	debug "high" ("SERVER HASH AFTER SERVERHELLODONE" :: String)+	debug "high" =<< handshakeHash 	maybe (return Nothing) (liftM Just . clientCertificate) mcs  clientCertificate :: (ValidateHandle h, CPRG g) =>@@ -233,16 +256,18 @@ 	Epms epms <- readHandshake 	debug "low" ("EPMS" :: String) 	debug "low" epms-	generateKeys Server rs =<< mkpms epms `E.catchError` const+	generateKeys Server rs =<< mkpms epms `catchError` const 		((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46) 	where 	mkpms epms = do 		pms <- decryptRsa sk epms-		unless (BS.length pms == 48) $ E.throwError "mkpms: length"+		unless (BS.length pms == 48) $+			throwError ALFatal ADHandshakeFailure "" 		case BS.unpack $ BS.take 2 pms of 			[pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $-				E.throwError "mkpms: version"-			_ -> E.throwError "mkpms: never occur"+				throwError ALFatal ADHandshakeFailure ""+			_ -> error $ "Network.PeyoTLS.Server." +++				"rsaClientKeyExchange: never occur" 		debug "low" ("PMS" :: String) 		debug "low" pms 		return pms@@ -254,8 +279,8 @@ 	ClientKeyExchange cke <- readHandshake 	let Right pv = B.decode cke 	generateKeys Server rs =<< case Right $ calculateShared dp sv pv of-		Left em -> E.throwError . E.strMsg $-			"TlsServer.dhClientKeyExchange: " ++ em+		Left em -> throwError ALFatal ADInternalError $+			"Network.PeyoTLS.Server.dhClientKeyExchange: " ++ em 		Right sh -> return sh  certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g ()@@ -288,62 +313,3 @@ 		(either error id $ B.decode y) certificateVerify p = throwError ALFatal ADUnsupportedCertificate $ 	"TlsServer.certificateVerify: not implement: " ++ show p--newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g }--instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where-	type HandleMonad (TlsHandleS h g) = HandleMonad (TlsHandle h g)-	type DebugLevel (TlsHandleS h g) = DebugLevel (TlsHandle h g)-	hlPut (TlsHandleS t) = hlPut t-	hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleS-	hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleS-	hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleS-	hlDebug (TlsHandleS t) = hlDebug t-	hlClose (TlsHandleS t) = hlClose t--hlGet_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleS h g -> Int -> TlsM h g BS.ByteString-hlGet_ (TlsHandleS t) n = do-	bf <- HB.getAdBuf t-	if (BS.length bf >= 0)-	then do	let (ret, rest) = BS.splitAt n bf-		HB.setAdBuf t rest-		return ret-	else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf)--hlGetLine_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleS h g -> TlsM h g BS.ByteString-hlGetLine_ (TlsHandleS t) = do-	bf <- HB.getAdBuf t-	if (10 `BS.elem` bf)-	then do	let (ret, rest) = BS.span (/= 10) bf-		HB.setAdBuf t $ BS.tail rest-		return ret-	else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t--hlGetContent_ :: (ValidateHandle h, CPRG g) =>-	TlsHandleS h g -> TlsM h g BS.ByteString-hlGetContent_ (TlsHandleS t) = do-	bf <- HB.getAdBuf t-	if BS.null bf-	then hlGetContentRn rehandshake t-	else do	HB.setAdBuf t ""-		return bf--type Version = (Word8, Word8)--version :: Version-version = (3, 3)--filterCS :: [(CertSecretKey, X509.CertificateChain)] ->-	[CipherSuite] -> [CipherSuite]-filterCS crts cs = case find isEcdsa crts of-	Just _ -> cs-	_ -> filter (not . isEcdsaCS) cs-	where-	isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True-	isEcdsaCS _ = False--isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool-isEcdsa (EcdsaKey _, _) = True-isEcdsa _ = False

@@ -3,7 +3,7 @@ module Network.PeyoTLS.State ( 	HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys, 	ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),-	CipherSuite(..), KeyExchange(..), BulkEncryption(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..), 	randomGen, setRandomGen, 	getBuf, setBuf, getWBuf, setWBuf, 	getAdBuf, setAdBuf,@@ -15,6 +15,7 @@ 	getServerFinished, setServerFinished,  	InitialSettings,+	CertSecretKey(..), ) where  import "monads-tf" Control.Monad.Error.Class (Error(strMsg))@@ -25,13 +26,16 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import Network.PeyoTLS.CertSecretKey+import Network.PeyoTLS.CertSecretKey (CertSecretKey(..)) import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509  import Network.PeyoTLS.CipherSuite (-	CipherSuite(..), KeyExchange(..), BulkEncryption(..))+	CipherSuite(..), KeyEx(..), BulkEnc(..)) +import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+ data HandshakeState h g = HandshakeState { 	randomGen :: g, nextPartnerId :: Int, 	states :: [(PartnerId, StateOne g)] }@@ -53,12 +57,14 @@ 		radBuffer = "", 		readSN = 0, writeSN = 0, 		rnClientFinished = "", rnServerFinished = "",-		initialSettings = ([], [], Nothing)+		initialSettings = ([], Nothing, Nothing, Nothing) 		} 	sos = states s  type InitialSettings = (-	[CipherSuite], [(CertSecretKey, X509.CertificateChain)],+	[CipherSuite],+	Maybe (RSA.PrivateKey, X509.CertificateChain),+	Maybe (ECDSA.PrivateKey, X509.CertificateChain), 	Maybe X509.CertificateStore)  data StateOne g = StateOne {@@ -70,9 +76,7 @@ 	writeSN :: Word64, 	rnClientFinished :: BS.ByteString, 	rnServerFinished :: BS.ByteString,-	initialSettings :: (-		[CipherSuite], [(CertSecretKey, X509.CertificateChain)],-		Maybe X509.CertificateStore)+	initialSettings :: InitialSettings 	}  getState :: PartnerId -> HandshakeState h g -> StateOne g@@ -131,10 +135,13 @@ data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show  data AlertDesc-	= ADCloseNotify            | ADUnexpectedMessage  | ADBadRecordMac-	| ADUnsupportedCertificate | ADCertificateExpired | ADCertificateUnknown-	| ADIllegalParameter       | ADUnknownCa          | ADDecodeError-	| ADDecryptError           | ADProtocolVersion    | ADRaw Word8+	= ADCloseNotify            | ADUnexpectedMessage    | ADBadRecordMac+	| ADRecordOverflow         | ADDecompressionFailure | ADHandshakeFailure+	| ADUnsupportedCertificate | ADCertificateExpired   | ADCertificateUnknown+	| ADIllegalParameter       | ADUnknownCa            | ADDecodeError+	| ADDecryptError           | ADProtocolVersion      | ADInsufficientSecurity+	| ADInternalError+	| ADRaw Word8 	deriving Show  instance Error Alert where

@@ -1,394 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}--module Network.PeyoTLS.TlsHandle (-	TlsM, Alert(..), AlertLevel(..), AlertDesc(..),-		run, withRandom, randomByteString,-	TlsHandle(..), 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,--	getInitSetT, setInitSetT,-	InitialSettings,--	resetSequenceNumber,-	tlsGet_,-	flushAppData,--	getAdBufT, setAdBufT,-	) where--import Prelude hiding (read)--import Control.Arrow (second)-import Control.Monad (liftM, ap, 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 Data.HandleLike (HandleLike(..))-import "crypto-random" Crypto.Random (CPRG)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.Hash.SHA256 as SHA256--import Network.PeyoTLS.TlsMonad (-	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(..), BulkEncryption(..),-	PartnerId, newPartnerId, Keys(..),-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,-	InitialSettings,-	getInitSet, setInitSet,-	)-import qualified Network.PeyoTLS.CryptoTools as CT (-	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash )--data TlsHandle h g = TlsHandle {-	clientId :: PartnerId,-	tlsHandle :: h, names :: [String] }--type HandleHash h g = (TlsHandle h g, SHA256.Ctx)--data Side = Server | Client deriving (Show, Eq)--run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a-run m g = do-	ret <- (`evalTlsM` 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 (TlsHandle h g)-newHandle h = do-	s <- get-	let (i, s') = newPartnerId s-	put s'-	return TlsHandle {-		clientId = i, tlsHandle = h, names = [] }--getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType-getContentType t = do-	ct <- fst `liftM` getBuf (clientId t)-	(\gt -> case ct of CTNull -> gt; _ -> return ct) $ do-		(ct', bf) <- getWholeWithCt t-		setBuf (clientId t) (ct', bf)-		return ct'--flushAppData :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (BS.ByteString, Bool)-flushAppData t = do-	ct <- getContentType t-	case ct of-		CTAppData -> do-			(_, ad) <- tGetContent t-			(bs, b) <- flushAppData t-			return (ad `BS.append` bs, b)---			liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t-		CTAlert -> do-			((_, a), _) <- tlsGet True (t, undefined) 2-			case a of-				"\1\0" -> return ("", False)-				_ -> throwError "flushAppData"-		_ -> return ("", True)--tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g ->-	Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g)-tlsGet b hh@(t, _) n = do-	r@(ct, bs) <- buffered t n-	(r ,) `liftM` case (ct, b, bs) of-		(CTHandshake, _, "\0\0\0\0") -> return hh-		(CTHandshake, True, _) -> updateHash hh bs-		_ -> return hh--tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->-	HandleHash h g -> Int ->-	TlsM h g ((ContentType, BS.ByteString), HandleHash h g)-tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n--buffered :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)-buffered t n = do-	(ct, b) <- getBuf $ clientId 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 $-			"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')-		second (b `BS.append`) `liftM` buffered t rl--buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->-	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)-buffered_ 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-			if rl <= 0-			then splitRetBuf t n ct b-			else do (ct', b') <- getWholeWithCt t-				unless (ct' == ct) . throwError . strMsg $-					"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--splitRetBuf :: HandleLike h =>-	TlsHandle h g -> Int -> ContentType -> BS.ByteString ->-	TlsM h g (ContentType, BS.ByteString)-splitRetBuf t n ct b = do-	let (ret, b') = BS.splitAt n b-	setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')-	return (ct, ret)--getWholeWithCt :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)-getWholeWithCt t = do-	flush t-	ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1-	[_vmj, _vmn] <- BS.unpack `liftM` read t 2-	e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2-	when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null"-	p <- decrypt t ct e-	thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct-	thlDebug (tlsHandle t) "medium" . BSC.pack . (++  "\n") . show $ BS.head p-	thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p-	return (ct, p)--read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString-read t n = do-	r <- thlGet (tlsHandle t) n-	unless (BS.length r == n) . throwError . strMsg $-		"TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n-	return r--decrypt :: HandleLike h =>-	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-decrypt t ct e = do-	ks <- getKeys $ clientId t-	decrypt_ t ks ct e--decrypt_ :: HandleLike h => TlsHandle h g ->-	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-decrypt_ _ Keys{ kReadCS = CipherSuite _ 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-	hs <- case be of-		AES_128_CBC_SHA -> return CT.hashSha1-		AES_128_CBC_SHA256 -> return CT.hashSha256-		_ -> throwError "TlsHandle.decrypt: not implement bulk encryption"-	either (throwError . strMsg) return $-		CT.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-	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-		(CTHandshake, True) -> updateHash hh p-		_ -> return hh--flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()-flush t = do-	(bct, bp) <- getWBuf $ clientId t-	setWBuf (clientId t) (CTNull, "")-	unless (bct == CTNull) $ do-		e <- encrypt t bct bp-		thlPut (tlsHandle t) $ BS.concat [-			B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ]--encrypt :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-encrypt t ct p = do-	ks <- getKeys $ clientId t-	encrypt_ t ks ct p--encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g ->-	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p-encrypt_ t ks ct p = do-	let	CipherSuite _ be = kWriteCS ks-		wk = kWriteKey ks-		mk = kWriteMacKey ks-	sn <- updateSequenceNumber t Write-	hs <- case be of-		AES_128_CBC_SHA -> return CT.hashSha1-		AES_128_CBC_SHA256 -> return CT.hashSha256-		_ -> throwError "TlsHandle.encrypt: not implemented bulk encryption"-	withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p--updateHash ::-	HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g)-updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs)--updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64-updateSequenceNumber t rw = do-	ks <- getKeys $ clientId t-	(sn, cs) <- case rw of-		Read -> (, kReadCS ks) `liftM` getReadSn (clientId t)-		Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t)-	case cs of-		CipherSuite _ BE_NULL -> return ()-		_ -> case rw of-			Read -> succReadSn $ clientId t-			Write -> succWriteSn $ clientId t-	return sn--resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g ()-resetSequenceNumber t rw = case rw of-	Read -> resetReadSn $ clientId t-	Write -> resetWriteSn $ clientId t--generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite ->-	BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys-generateKeys t p cs cr sr pms = do-	let CipherSuite _ be = cs-	kl <- case be of-		AES_128_CBC_SHA -> return 20-		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-	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--flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g ()-flushCipherSuiteSt p = case p of-	Read -> flushCipherSuiteRead-	Write -> flushCipherSuiteWrite--debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g ()-debugCipherSuite t a = do-	k <- getKeys $ clientId t-	thlDebug (tlsHandle t) "high" . BSC.pack-		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50-		. show $ 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) => TlsHandle h g -> BS.ByteString -> TlsM h g ()-hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined)--hlDebug_ :: HandleLike h =>-	TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g ()-hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l--hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()-hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >>-	flush t >> thlClose (tlsHandle t)--tGetLine :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)-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--tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)-tGetLine_ rn t = do-	ct <- getContentType t-	case ct of-		CTHandshake -> rn t >> tGetLine_ rn t-		_ -> do	(bct, bp) <- getBuf $ clientId t-			case splitLine bp of-				Just (l, ls) -> do-					setBuf (clientId t) (bct, ls)-					return (bct, l)-				_ -> do	cp <- getWholeWithCt t-					setBuf (clientId t) cp-					second (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-	(True, _) -> let-		(l, ls) = BSC.span (/= '\r') bs-		Just ('\r', ls') = BSC.uncons ls in-		case BSC.uncons ls' of-			Just ('\n', ls'') -> Just (l, ls'')-			_ -> Just (l, ls')-	(_, True) -> let-		(l, ls) = BSC.span (/= '\n') bs-		Just ('\n', ls') = BSC.uncons ls in Just (l, ls')-	_ -> Nothing--tGetContent :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)-tGetContent t = do-	bcp@(_, bp) <- getBuf $ clientId t-	if BS.null bp then getWholeWithCt t else-		setBuf (clientId t) (CTNull, BS.empty) >> return bcp--getClientFinishedT, getServerFinishedT ::-	HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString-getClientFinishedT = getClientFinished . clientId-getServerFinishedT = getServerFinished . clientId--setClientFinishedT, setServerFinishedT ::-	HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()-setClientFinishedT = setClientFinished . clientId-setServerFinishedT = setServerFinished . clientId--getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings-getInitSetT = getInitSet . clientId--setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g ()-setInitSetT = setInitSet . clientId--getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString-getAdBufT = getAdBuf . clientId--setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()-setAdBufT = setAdBuf . clientId

@@ -1,135 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Network.PeyoTLS.TlsMonad (-	TlsM, evalTlsM, S.initState,-		thlGet, thlPut, thlClose, thlDebug, thlError,-		withRandom, randomByteString,-		getBuf, setBuf, getWBuf, setWBuf,-		getAdBuf, setAdBuf,-		getReadSn, getWriteSn, succReadSn, succWriteSn,-		resetReadSn, resetWriteSn,-		getCipherSuiteSt, setCipherSuiteSt,-		flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,-		getInitSet, setInitSet, S.InitialSettings,-	S.Alert(..), S.AlertLevel(..), S.AlertDesc(..),-	S.ContentType(..),-	S.CipherSuite(..), S.KeyExchange(..), S.BulkEncryption(..),-	S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys,--	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,-	) where--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 Data.Word (Word64)-import Data.HandleLike (HandleLike(..))-import "crypto-random" Crypto.Random (CPRG, cprgGenerate)--import qualified Data.ByteString as BS--import qualified Network.PeyoTLS.State as S (-	HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,-	ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),-	CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	randomGen, setRandomGen,-	setBuf, getBuf, setWBuf, getWBuf,-	setAdBuf, getAdBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN,-	getCipherSuite, setCipherSuite,-	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,-	getInitSet, setInitSet,-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,--	InitialSettings,-	)--type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h))--evalTlsM :: HandleLike h => -	TlsM h g a -> S.HandshakeState h g -> HandleMonad h (Either S.Alert a)-evalTlsM = evalStateT . runErrorT--getBuf, getWBuf ::  HandleLike h =>-	S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString)-getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf--getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString-getAdBuf = gets . S.getAdBuf--setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()-setAdBuf = (modify .) . S.setAdBuf--setBuf, setWBuf :: HandleLike h =>-	S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()-setBuf = (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--succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()-succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN--resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()-resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN--getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite-getCipherSuiteSt = gets . S.getCipherSuite--setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()-setCipherSuiteSt = (modify .) . S.setCipherSuite--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.InitialSettings-getInitSet = gets . S.getInitSet--setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g ()-setInitSet = (modify .) . S.setInitSet--getClientFinished, getServerFinished ::-	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString-getClientFinished = gets . S.getClientFinished-getServerFinished = gets . S.getServerFinished--setClientFinished, setServerFinished ::-	HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()-setClientFinished = (modify .) . S.setClientFinished-setServerFinished = (modify .) . S.setServerFinished--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--thlGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString-thlGet = ((lift . lift) .) . hlGet--thlPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()-thlPut = ((lift . lift) .) . hlPut--thlClose :: HandleLike h => h -> TlsM h g ()-thlClose = lift . lift . hlClose--thlDebug :: HandleLike h =>-	h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()-thlDebug = (((lift . lift) .) .) . hlDebug--thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a-thlError = ((lift . lift) .) . hlError

@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Types ( Extension(..),+	Handshake(..), HandshakeItem(..),+	ClientHello(..), ServerHello(..), SessionId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CompMethod(..),+	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+		SignAlg(..), HashAlg(..),+	ServerHelloDone(..), ClientKeyExchange(..), Epms(..),+	DigitallySigned(..), Finished(..) ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless)+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.Hello ( Extension(..),+	ClientHello(..), ServerHello(..), SessionId(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	CompMethod(..), HashAlg(..), SignAlg(..) )+import Network.PeyoTLS.Certificate (+	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+	ClientKeyExchange(..), DigitallySigned(..) )++data Handshake+	= HHelloReq+	| HClientHello ClientHello           | HServerHello ServerHello+	| HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString+	| HCertificateReq CertificateRequest | HServerHelloDone+	| HCertVerify DigitallySigned        | HClientKeyEx ClientKeyExchange+	| HFinished BS.ByteString            | HRaw Type BS.ByteString+	deriving Show++instance B.Bytable Handshake where+	decode = B.evalBytableM B.parse; encode = encodeH++instance B.Parsable Handshake where+	parse = do+		t <- B.take 1+		len <- B.take 3+		case t of+			THelloRequest -> do+				unless (len == 0) $ fail "parse Handshake"+				return HHelloReq+			TClientHello -> HClientHello <$> B.take len+			TServerHello -> HServerHello <$> B.take len+			TCertificate -> HCertificate <$> B.take len+			TServerKeyEx -> HServerKeyEx <$> B.take len+			TCertificateReq -> HCertificateReq <$> B.take len+			TServerHelloDone -> let 0 = len in return HServerHelloDone+			TCertVerify -> HCertVerify <$> B.take len+			TClientKeyEx -> HClientKeyEx <$> B.take len+			TFinished -> HFinished <$> B.take len+			_ -> HRaw t <$> B.take len++encodeH :: Handshake -> BS.ByteString+encodeH HHelloReq = encodeH $ HRaw THelloRequest ""+encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch+encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh+encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts+encodeH (HServerKeyEx ske) = encodeH $ HRaw TServerKeyEx ske+encodeH (HCertificateReq cr) = encodeH . HRaw TCertificateReq $ B.encode cr+encodeH HServerHelloDone = encodeH $ HRaw TServerHelloDone ""+encodeH (HCertVerify ds) = encodeH . HRaw TCertVerify $ B.encode ds+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++class HandshakeItem hi where+	fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake++instance HandshakeItem Handshake where+	fromHandshake = Just; toHandshake = id++instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where+	fromHandshake hs = let+		l = fromHandshake hs+		r = fromHandshake hs in maybe (Right <$> r) (Just . Left) l+	toHandshake (Left l) = toHandshake l+	toHandshake (Right r) = toHandshake r++instance HandshakeItem ClientHello where+	fromHandshake (HClientHello ch) = Just ch+	fromHandshake _ = Nothing+	toHandshake = HClientHello++instance HandshakeItem ServerHello where+	fromHandshake (HServerHello sh) = Just sh+	fromHandshake _ = Nothing+	toHandshake = HServerHello++instance HandshakeItem X509.CertificateChain where+	fromHandshake (HCertificate cc) = Just cc+	fromHandshake _ = Nothing+	toHandshake = HCertificate++data ServerKeyExchange = ServerKeyEx BS.ByteString BS.ByteString+	HashAlg SignAlg BS.ByteString deriving Show++data ServerKeyExDhe = ServerKeyExDhe DH.Params DH.PublicNumber+	HashAlg SignAlg BS.ByteString deriving Show++data ServerKeyExEcdhe = ServerKeyExEcdhe ECC.Curve ECC.Point+	HashAlg SignAlg BS.ByteString deriving Show++instance HandshakeItem ServerKeyExchange where+	fromHandshake = undefined+	toHandshake = HServerKeyEx . B.encode++instance HandshakeItem ServerKeyExDhe where+	toHandshake = HServerKeyEx . B.encode+	fromHandshake (HServerKeyEx ske) =+		either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing++instance HandshakeItem ServerKeyExEcdhe where+	toHandshake = HServerKeyEx . B.encode+	fromHandshake (HServerKeyEx ske) =+		either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing++instance B.Bytable ServerKeyExchange where+	decode = undefined+	encode (ServerKeyEx ps pv ha sa sn) = BS.concat [+		ps, pv, B.encode ha, B.encode sa,+		B.addLen (undefined :: Word16) sn ]++instance B.Bytable ServerKeyExDhe where+	encode (ServerKeyExDhe ps pv ha sa sn) = BS.concat [+		B.encode ps, B.encode pv, B.encode ha, B.encode sa,+		B.addLen (undefined :: Word16) sn ]+	decode = B.evalBytableM B.parse++instance B.Bytable ServerKeyExEcdhe where+	encode (ServerKeyExEcdhe cv pnt ha sa sn) = BS.concat [+		B.encode cv, B.encode pnt, B.encode ha, B.encode sa,+		B.addLen (undefined :: Word16) sn ]+	decode = B.evalBytableM B.parse++instance B.Parsable ServerKeyExDhe where+	parse = do+		ps <- B.parse+		pv <- B.parse+		(ha, sa, sn) <- hasasn+		return $ ServerKeyExDhe ps pv ha sa sn++instance B.Parsable ServerKeyExEcdhe where+	parse = do+		cv <- B.parse+		pnt <- B.parse+		(ha, sa, sn) <- hasasn+		return $ ServerKeyExEcdhe cv pnt ha sa sn++hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString)+hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2)++instance HandshakeItem CertificateRequest where+	fromHandshake (HCertificateReq cr) = Just cr+	fromHandshake _ = Nothing+	toHandshake = HCertificateReq++instance HandshakeItem ServerHelloDone where+	fromHandshake HServerHelloDone = Just ServerHelloDone+	fromHandshake _ = Nothing+	toHandshake _ = HServerHelloDone++instance HandshakeItem DigitallySigned where+	fromHandshake (HCertVerify ds) = Just ds+	fromHandshake _ = Nothing+	toHandshake = HCertVerify++instance HandshakeItem ClientKeyExchange where+	fromHandshake (HClientKeyEx cke) = Just cke+	fromHandshake _ = Nothing+	toHandshake = HClientKeyEx++data Epms = Epms BS.ByteString++instance HandshakeItem Epms where+	fromHandshake (HClientKeyEx cke) = ckeToEpms cke+	fromHandshake _ = Nothing+	toHandshake = HClientKeyEx . epmsToCke++ckeToEpms :: ClientKeyExchange -> Maybe Epms+ckeToEpms (ClientKeyExchange cke) = case B.runBytableM (B.take =<< B.take 2) cke of+	Right (e, "") -> Just $ Epms e+	_ -> Nothing++epmsToCke :: Epms -> ClientKeyExchange+epmsToCke (Epms epms) = ClientKeyExchange $ B.addLen (undefined :: Word16) epms++data Finished = Finished BS.ByteString deriving (Show, Eq)++instance HandshakeItem Finished where+	fromHandshake (HFinished f) = Just $ Finished f+	fromHandshake _ = Nothing+	toHandshake (Finished f) = HFinished f++data ServerHelloDone = ServerHelloDone deriving Show++data Type+	= THelloRequest | TClientHello | TServerHello+	| TCertificate  | TServerKeyEx | TCertificateReq | TServerHelloDone+	| TCertVerify   | TClientKeyEx | TFinished       | TRaw Word8+	deriving Show++instance B.Bytable Type where+	decode bs = case BS.unpack bs of+		[0] -> Right THelloRequest+		[1] -> Right TClientHello+		[2] -> Right TServerHello+		[11] -> Right TCertificate+		[12] -> Right TServerKeyEx+		[13] -> Right TCertificateReq+		[14] -> Right TServerHelloDone+		[15] -> Right TCertVerify+		[16] -> Right TClientKeyEx+		[20] -> Right TFinished+		[ht] -> Right $ TRaw ht+		_ -> Left "Handshake.decodeT"+	encode THelloRequest = BS.pack [0]+	encode TClientHello = BS.pack [1]+	encode TServerHello = BS.pack [2]+	encode TCertificate = BS.pack [11]+	encode TServerKeyEx = BS.pack [12]+	encode TCertificateReq = BS.pack [13]+	encode TServerHelloDone = BS.pack [14]+	encode TCertVerify = BS.pack [15]+	encode TClientKeyEx = BS.pack [16]+	encode TFinished = BS.pack [20]+	encode (TRaw w) = BS.pack [w]

@@ -40,7 +40,7 @@ main :: IO () main = do 	b <- randomIO-	(if b then runRsa "low" else ecdsa "low") =<< randomFrom cipherSuites+	(if b then runRsa "critical" else ecdsa "critical") =<< randomFrom cipherSuites  runRsa :: Priority -> [CipherSuite] -> IO () runRsa p cs = do