peyotls 0.0.0.24 → 0.1.0.0

raw patch · 24 files changed

+1702/−2021 lines, 24 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• peyotls.cabal +9/−9
• src/Network/PeyoTLS/Base.hs +30/−31
• src/Network/PeyoTLS/Certificate.hs +0/−103
• src/Network/PeyoTLS/CipherSuite.hs +29/−42
• src/Network/PeyoTLS/Client.hs +46/−53
• src/Network/PeyoTLS/Codec.hs +236/−0
• src/Network/PeyoTLS/Codec/Certificate.hs +93/−0
• src/Network/PeyoTLS/Codec/Extension.hs +230/−0
• src/Network/PeyoTLS/Codec/HSAlg.hs +40/−0
• src/Network/PeyoTLS/Codec/Hello.hs +77/−0
• src/Network/PeyoTLS/Crypto.hs +0/−105
• src/Network/PeyoTLS/Extension.hs +0/−220
• src/Network/PeyoTLS/HSAlg.hs +0/−42
• src/Network/PeyoTLS/Handle.hs +0/−496
• src/Network/PeyoTLS/Hello.hs +0/−94
• src/Network/PeyoTLS/Monad.hs +0/−176
• src/Network/PeyoTLS/Run.hs +60/−61
• src/Network/PeyoTLS/Run/Crypto.hs +96/−0
• src/Network/PeyoTLS/Run/Handle.hs +288/−0
• src/Network/PeyoTLS/Run/Monad.hs +208/−0
• src/Network/PeyoTLS/Run/State.hs +219/−0
• src/Network/PeyoTLS/Server.hs +41/−48
• src/Network/PeyoTLS/State.hs +0/−275
• src/Network/PeyoTLS/Types.hs +0/−266

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.24+version:	0.1.0.0 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -283,7 +283,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.24+    tag:	peyotls-0.1.0.0  library     hs-source-dirs:	src@@ -291,14 +291,14 @@         Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile     other-modules:         Network.PeyoTLS.Base,-        Network.PeyoTLS.Types,-            Network.PeyoTLS.Hello, Network.PeyoTLS.Extension,-                Network.PeyoTLS.CipherSuite, Network.PeyoTLS.HSAlg,-            Network.PeyoTLS.Certificate,+        Network.PeyoTLS.Codec,+            Network.PeyoTLS.Codec.Hello, Network.PeyoTLS.Codec.Extension,+                Network.PeyoTLS.CipherSuite, Network.PeyoTLS.Codec.HSAlg,+            Network.PeyoTLS.Codec.Certificate,         Network.PeyoTLS.Run,-            Network.PeyoTLS.Handle,-                Network.PeyoTLS.Monad, Network.PeyoTLS.State,-                Network.PeyoTLS.Crypto,+            Network.PeyoTLS.Run.Handle,+                Network.PeyoTLS.Run.Monad, Network.PeyoTLS.Run.State,+                Network.PeyoTLS.Run.Crypto,         Network.PeyoTLS.Ecdsa, Network.PeyoTLS.CertSecretKey     build-depends:         base == 4.*, word24 == 1.0.*, bytestring == 0.10.*, monads-tf == 0.1.*,

@@ -9,23 +9,22 @@ 		AlertLevel(..), AlertDesc(..), throw, 		debugCipherSuite, debug, 	ValidateHandle(..), handshakeValidate, validateAlert,-	TlsHandleBase, names, getNames,+	HandleBase, getNames, 		CertSecretKey(..), isRsaKey, isEcdsaKey, 		readHandshake, writeHandshake,-		ChangeCipherSpec(..),+		CCSpec(..), 	Handshake(HHelloReq),-	ClientHello(..), ServerHello(..), SessionId(..), Extension(..),-		isRenegoInfo, emptyRenegoInfo,+	ClHello(..), SvHello(..), SssnId(..), Extension(..), isRnInfo, emptyRnInfo, 		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..), HashAlg(..), SignAlg(..),+		CmpMtd(..), HashAlg(..), SignAlg(..), 		getCipherSuite, setCipherSuite, 		checkClRenego, checkSvRenego, makeClRenego, makeSvRenego,-	ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+	SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..), 		SvSignSecretKey(..), SvSignPublicKey(..), 	CertReq(..), certReq, ClCertType(..),-	ServerHelloDone(..),-	ClientKeyEx(..), Epms(..), makeKeys,-	DigitallySigned(..), ClSignPublicKey(..), ClSignSecretKey(..),+	SHDone(..),+	ClKeyEx(..), Epms(..), makeKeys,+	DigitSigned(..), ClSignPublicKey(..), ClSignSecretKey(..), 		handshakeHash, 	RW(..), flushCipherSuite, 	Side(..), finishedHash,@@ -33,7 +32,7 @@  import Control.Arrow (first) import Control.Monad (unless, liftM, ap)-import "monads-tf" Control.Monad.State (gets, lift)+import "monads-tf" Control.Monad.Reader (lift, ask) import Data.Bits (shiftR) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)@@ -59,18 +58,18 @@ import qualified Crypto.PubKey.HashDescr as HD import qualified Crypto.PubKey.RSA.PKCS15 as RSA -import Network.PeyoTLS.Types (+import Network.PeyoTLS.Codec ( 	Handshake(..), HandshakeItem(..),-	ClientHello(..), ServerHello(..), SessionId(..),+	ClHello(..), SvHello(..), SssnId(..), 		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo,-	ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),+		CmpMtd(..), Extension(..), isRnInfo, emptyRnInfo,+	SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..), 	CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..),-	ServerHelloDone(..), ClientKeyEx(..), Epms(..),-	DigitallySigned(..), ChangeCipherSpec(..), Finished(..) )+	SHDone(..), ClKeyEx(..), Epms(..),+	DigitSigned(..), CCSpec(..), Finished(..) ) import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run (-	TlsM, run, TlsHandleBase(..), getNames,+	TlsM, run, HandleBase, getNames, 		chGet, hsPut, updateHash, ccsPut, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM,@@ -93,8 +92,8 @@  debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HandshakeM h g () debug p x = do-	t <- gets fst-	lift . RUN.debug t p . BSC.pack . (++ "\n") $ show x+	t <- ask+	lift . lift . RUN.debug t p . BSC.pack . (++ "\n") $ show x  readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HandshakeM h g hi readHandshake = do@@ -102,17 +101,17 @@ 	case ch of 		Left 1 -> case fromHandshake HCCSpec of 			Just i -> return i-			_ -> throw ALFatal ADUnexMsg $+			_ -> throw ALFtl ADUnexMsg $ 				modNm ++ ".readHandshake: " ++ show HCCSpec 		Right bs -> case B.decode bs of 			Right HHelloReq -> readHandshake 			Right hs -> case fromHandshake hs of 				Just i -> updateHash bs >> return i-				_ -> throw ALFatal ADUnexMsg $+				_ -> throw ALFtl ADUnexMsg $ 					modNm ++ ".readHandshake: " ++ show hs-			Left em -> throw ALFatal ADInternalError $+			Left em -> throw ALFtl ADInternalErr $ 				modNm ++ ".readHandshake: " ++ em-		_ -> throw ALFatal ADUnexMsg $ modNm ++ ".readHandshake: uk ccs"+		_ -> throw ALFtl ADUnexMsg $ modNm ++ ".readHandshake: uk ccs"  writeHandshake:: (HandleLike h, CPRG g, HandshakeItem hi) => hi -> HandshakeM h g () writeHandshake hi = do@@ -131,23 +130,23 @@ 	return fh  checkClRenego, checkSvRenego :: HandleLike h => Extension -> HandshakeM h g ()-checkClRenego (ERenegoInfo ri) = do+checkClRenego (ERnInfo ri) = do 	ok <- (ri ==) `liftM` getClFinished-	unless ok . throw ALFatal ADHsFailure $+	unless ok . throw ALFtl ADHsFailure $ 		modNm ++ ".checkClRenego: renego info is not match"-checkClRenego _ = throw ALFatal ADInternalError $+checkClRenego _ = throw ALFtl ADInternalErr $ 	modNm ++ ".checkClRenego: not renego info"-checkSvRenego (ERenegoInfo ri) = do+checkSvRenego (ERnInfo ri) = do 	ok <- (ri ==) `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished)-	unless ok . throw ALFatal ADHsFailure $+	unless ok . throw ALFtl ADHsFailure $ 		modNm ++ ".checkSvRenego: renego info is not match"-checkSvRenego _ = throw ALFatal ADInternalError $+checkSvRenego _ = throw ALFtl ADInternalErr $ 	modNm ++ ".checkSvRenego: not renego info"  makeClRenego, makeSvRenego :: HandleLike h => HandshakeM h g Extension-makeClRenego = ERenegoInfo `liftM` getClFinished+makeClRenego = ERnInfo `liftM` getClFinished makeSvRenego =-	ERenegoInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished)+	ERnInfo `liftM` (BS.append `liftM` getClFinished `ap` getSvFinished)  class DhParam b where 	type Secret b

@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.PeyoTLS.Certificate (-	CertReq(..), certReq, ClCertType(..),-	ClientKeyEx(..), DigitallySigned(..)) where--import Control.Applicative ((<$>), (<*>))-import Data.Word (Word8, Word16)-import Data.Word.Word24 (Word24)--import qualified Data.ByteString as BS-import qualified Data.ASN1.Types as ASN1-import qualified Data.ASN1.Encoding as ASN1-import qualified Data.ASN1.BinaryEncoding as ASN1-import qualified Data.X509 as X509-import qualified Data.X509.CertificateStore as X509-import qualified Codec.Bytable.BigEndian as B--import Network.PeyoTLS.HSAlg (HashAlg, SignAlg)--instance B.Bytable X509.CertificateChain where-	decode = B.evalBytableM B.parse-	encode = B.addLen w24 . cmap (B.addLen w24)-		. (\(X509.CertificateChainRaw ccr) -> ccr)-		. X509.encodeCertificateChain-		. (\(X509.CertificateChain cs) ->-			X509.CertificateChain $ cs)--instance B.Parsable X509.CertificateChain where-	parse = do-		ecc <- X509.decodeCertificateChain . X509.CertificateChainRaw <$>-			(flip B.list (B.take =<< B.take 3) =<< B.take 3)-		case ecc of-			Right (X509.CertificateChain cs) ->-				return . X509.CertificateChain $ cs-			Left (n, err) -> fail $ show n ++ " " ++ err--data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName]-	deriving Show--certReq :: [ClCertType] -> [(HashAlg, SignAlg)] ->-	X509.CertificateStore -> CertReq-certReq t a = CertReq t a-	. map (X509.certIssuerDN . X509.signedObject . X509.getSigned)-	. X509.listCertificates--instance B.Bytable CertReq where-	encode (CertReq t a n) = BS.concat [-		B.addLen w8 $ cmap B.encode t,-		B.addLen w16 . BS.concat $-			concatMap (\(h, s) -> [B.encode h, B.encode s]) a,-		B.addLen w16 . flip cmap n $ B.addLen w16 .-			ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ]---	encode (CertReq bs) = bs-	decode = B.evalBytableM $ do-		t <- flip B.list (B.take 1) =<< B.take 1-		a <- flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2-		n <- (B.take 2 >>=) . flip B.list $ do-			bs <- B.take =<< B.take 2-			a1 <- either (fail . show) return $-				ASN1.decodeASN1' ASN1.DER bs-			either (fail . show) (return . fst) $ ASN1.fromASN1 a1-		return $ CertReq t a n--data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8-	deriving (Show, Eq)--instance B.Bytable ClCertType where-	encode CTRsaSign = "\x01"-	encode CTEcdsaSign = "\x40"-	encode (CTRaw w) = BS.pack [w]-	decode bs = case BS.unpack bs of-		[w] -> Right $ case w of-			1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w-		_ -> Left "Certificate: ClCertType.decode"--data ClientKeyEx = ClientKeyEx BS.ByteString deriving Show--instance B.Bytable ClientKeyEx where-	decode = Right . ClientKeyEx-	encode (ClientKeyEx epms) = epms--data DigitallySigned-	= DigitallySigned (HashAlg, SignAlg) BS.ByteString-	| DigitallySignedRaw BS.ByteString-	deriving Show--instance B.Bytable DigitallySigned where-	decode = B.evalBytableM $-		DigitallySigned-			<$> ((,) <$> B.take 1 <*> B.take 1)-			<*> (B.take =<< B.take 2)-	encode (DigitallySigned (ha, sa) bs) = BS.concat [-		B.encode ha, B.encode sa, B.addLen w16 bs ]-	encode (DigitallySignedRaw bs) = bs--w8 :: Word8; w8 = undefined-w16 :: Word16; w16 = undefined-w24 :: Word24; w24 = undefined--cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString-cmap = (BS.concat .) . map

@@ -10,72 +10,59 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B +modNm :: String+modNm = "Network.PeyoTLS.CipherSuite"+ data CipherSuite 	= CipherSuite KeyEx BulkEnc 	| EMPTY_RENEGOTIATION_INFO 	| CipherSuiteRaw Word8 Word8 	deriving (Show, Read, Eq) -data KeyEx-	= RSA-	| DHE_RSA-	| ECDHE_RSA-	| ECDHE_ECDSA---	| ECDHE_PSK-	| KE_NULL+data KeyEx = RSA | DHE_RSA | ECDHE_RSA | ECDHE_ECDSA | KE_NULL 	deriving (Show, Read, Eq) -data BulkEnc-	= AES_128_CBC_SHA-	| AES_128_CBC_SHA256---	| CAMELLIA_128_CBC_SHA---	| NULL_SHA-	| BE_NULL+data BulkEnc = AES_128_CBC_SHA | AES_128_CBC_SHA256 | BE_NULL 	deriving (Show, Read, Eq)   instance B.Bytable CipherSuite where-	decode = decodeCipherSuite-	encode = encodeCipherSuite+	decode = decodeCs+	encode = encodeCs -decodeCipherSuite :: BS.ByteString -> Either String CipherSuite-decodeCipherSuite bs = case BS.unpack bs of+decodeCs :: BS.ByteString -> Either String CipherSuite+decodeCs bs = case BS.unpack bs of 	[w1, w2] -> Right $ case (w1, w2) of 		(0x00, 0x00) -> CipherSuite KE_NULL BE_NULL 		(0x00, 0x2f) -> CipherSuite RSA AES_128_CBC_SHA 		(0x00, 0x33) -> CipherSuite DHE_RSA AES_128_CBC_SHA---		(0x00, 0x39) -> CipherSuite ECDHE_PSK NULL_SHA 		(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) -> 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 		(0xc0, 0x27) -> CipherSuite ECDHE_RSA AES_128_CBC_SHA256+		(0x00, 0xff) -> EMPTY_RENEGOTIATION_INFO 		_ -> CipherSuiteRaw w1 w2-	_ -> Left "CipherSuite.decodeCipherSuite: not 2 byte"--encodeCipherSuite :: CipherSuite -> BS.ByteString-encodeCipherSuite (CipherSuite KE_NULL BE_NULL) = "\x00\x00"-encodeCipherSuite (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f"-encodeCipherSuite (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33"--- encodeCipherSuite (CipherSuite ECDHE_PSK NULL_SHA) = "\x00\x39"-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 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"-encodeCipherSuite (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27"-encodeCipherSuite (CipherSuiteRaw w1 w2) = BS.pack [w1, w2]-encodeCipherSuite _ = error "CipherSuite.encodeCipherSuite: unknown cipher suite"+	_ -> Left $ modNm ++ ".decodeCs: not 2 byte" -separateByWith :: String -> (String, String)-separateByWith "" = error "CipherSuite: parse error"-separateByWith ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be)-separateByWith (k : r) = (k :) `first` separateByWith r+encodeCs :: CipherSuite -> BS.ByteString+encodeCs (CipherSuite KE_NULL BE_NULL) = "\x00\x00"+encodeCs (CipherSuite RSA AES_128_CBC_SHA) = "\x00\x2f"+encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA) = "\x00\x33"+encodeCs (CipherSuite RSA AES_128_CBC_SHA256) = "\x00\x3c"+encodeCs (CipherSuite DHE_RSA AES_128_CBC_SHA256) = "\x00\x67"+encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA) = "\xc0\x09"+encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA) = "\xc0\x13"+encodeCs (CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256) = "\xc0\x23"+encodeCs (CipherSuite ECDHE_RSA AES_128_CBC_SHA256) = "\xc0\x27"+encodeCs (CipherSuiteRaw w1 w2) = BS.pack [w1, w2]+encodeCs EMPTY_RENEGOTIATION_INFO = "\x00\xff"+encodeCs _ = error $ modNm ++ ".encodeCs: unknown cipher suite"  instance IsString CipherSuite where-	fromString = uncurry CipherSuite . (read *** read) . separateByWith . drop 4+	fromString = uncurry CipherSuite . (read *** read) . sep . drop 4+		where+		sep "" = error $ modNm ++ ".separateByWith: parse error"+		sep ('_' : 'W' : 'I' : 'T' : 'H' : '_' : be) = ("", be)+		sep (k : r) = (k :) `first` sep r

@@ -12,7 +12,7 @@  module Network.PeyoTLS.Client ( 	-- * Basic-	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames,+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, getNames, 	-- * Renegotiation 	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, 	-- * Cipher Suite@@ -40,7 +40,7 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified "monads-tf" Control.Monad.Error as E -import qualified Network.PeyoTLS.Base as BASE (names, getNames)+import qualified Network.PeyoTLS.Base as BASE (getNames) import Network.PeyoTLS.Base ( debug, 	PeyotlsM, TlsM, run, 		getSettingsC, setSettingsC,@@ -49,24 +49,24 @@ 		withRandom, flushAd, 		AlertLevel(..), AlertDesc(..), throw, 	ValidateHandle(..), handshakeValidate, validateAlert,-	TlsHandleBase, CertSecretKey(..),-		readHandshake, writeHandshake, ChangeCipherSpec(..),-	ClientHello(..), ServerHello(..), SessionId(..), isRenegoInfo,+	HandleBase, CertSecretKey(..),+		readHandshake, writeHandshake, CCSpec(..),+	ClHello(..), SvHello(..), SssnId(..), isRnInfo, 		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..), HashAlg(..), SignAlg(..),+		CmpMtd(..), HashAlg(..), SignAlg(..), 		setCipherSuite, 		checkSvRenego, makeClRenego,-	ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..),+	SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..), 	CertReq(..), ClCertType(..),-	ServerHelloDone(..),-	ClientKeyEx(..), Epms(..), makeKeys,-	DigitallySigned(..), ClSignSecretKey(..), handshakeHash,+	SHDone(..),+	ClKeyEx(..), Epms(..), makeKeys,+	DigitSigned(..), ClSignSecretKey(..), handshakeHash, 	Side(..), RW(..), finishedHash, flushCipherSuite, 	DhParam(..), ecdsaPubKey )  type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandleBase h g } deriving Show+newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show  instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where 	type HandleMonad (TlsHandle h g) = TlsM h g@@ -78,13 +78,8 @@ 	hlDebug = adDebug . tlsHandleC 	hlClose = adClose . tlsHandleC -moduleName :: String-moduleName = "Network.PeyoTLS.Client"--{-# DEPRECATED names "Use getNames instead" #-}--names :: TlsHandle h g -> [String]-names = BASE.names . tlsHandleC+modNm :: String+modNm = "Network.PeyoTLS.Client"  getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleC@@ -119,7 +114,7 @@ 	(cscl, crts, _) <- getSettingsC 	setSettingsC (cscl, crts, cs) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g ()+rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do 	(cscl, crts, ca) <- getSettingsC 	handshake crts ca =<< clientHello cscl@@ -129,7 +124,7 @@ clientHello cscl = do 	cr <- withRandom $ cprgGenerate 32 	((>>) <$> writeHandshake <*> debug "low")-		. ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull]+		. ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull] 		. Just . (: []) =<< makeClRenego 	return cr @@ -143,24 +138,23 @@ 		DHE_RSA -> dheHandshake (undefined :: DH.Params) 		ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve) 		ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve)-		_ -> \_ _ _ -> throw ALFatal ADHsFailure $-			moduleName ++ ".handshake: not implemented"+		_ -> \_ _ _ -> throw ALFtl ADHsFailure $+			modNm ++ ".handshake: not implemented"  serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) serverHello = do-	ServerHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake+	SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake 	case v of 		(3, 3) -> return ()-		_ -> throw ALFatal ADProtocolVersion $-			moduleName ++ ".serverHello: only TLS 1.2"+		_ -> throw ALFtl ADProtoVer $+			modNm ++ ".serverHello: only TLS 1.2" 	case cm of-		CompMethodNull -> return ()-		_ -> throw ALFatal ADHsFailure $-			moduleName ++ ".serverHello: only compression method null"-	case find isRenegoInfo $ fromMaybe [] e of+		CmpMtdNull -> return ()+		_ -> throw ALFtl ADHsFailure $+			modNm ++ ".serverHello: only compression method null"+	case find isRnInfo $ fromMaybe [] e of 		Just ri -> checkSvRenego ri-		_ -> throw ALFatal ADInsufficientSecurity $-			moduleName ++ ".serverHello: require secure renegotiation"+		_ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego" 	setCipherSuite cs 	return (sr, ke) @@ -170,12 +164,11 @@ rsaHandshake rs crts ca = do 	cc@(X509.CertificateChain (c : _)) <- readHandshake 	vr <- handshakeValidate ca cc-	unless (null vr) . throw ALFatal (validateAlert vr) $-		moduleName ++ ".rsaHandshake: validate failure"+	unless (null vr) . throw ALFtl (validateAlert vr) $+		modNm ++ ".rsaHandshake: validate failure" 	pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of 		X509.PubKeyRSA k -> return k-		_ -> throw ALFatal ADIllegalParameter $-			moduleName ++ ".rsaHandshake: require RSA public key"+		_ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk" 	crt <- clientCertificate crts 	pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46) 	makeKeys Client rs pms@@ -195,13 +188,13 @@ dheHandshake t rs crts ca = do 	cc@(X509.CertificateChain (c : _)) <- readHandshake 	vr <- handshakeValidate ca cc-	unless (null vr) . throw ALFatal (validateAlert vr) $-		moduleName ++ ".succeed: validate failure"+	unless (null vr) . throw ALFtl (validateAlert vr) $+		modNm ++ ".succeed: validate failure" 	case X509.certPubKey . X509.signedObject $ X509.getSigned c of 		X509.PubKeyRSA pk -> succeed t pk rs crts 		X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts-		_ -> throw ALFatal ADHsFailure $-			moduleName ++ ".dheHandshake: not implemented"+		_ -> throw ALFtl ADHsFailure $+			modNm ++ ".dheHandshake: not implemented"  succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk, 		KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) =>@@ -210,16 +203,16 @@ succeed t pk rs@(cr, sr) crts = do 	(ps, pv, ha, sa, sn) <- serverKeyExchange 	let _ = ps `asTypeOf` t-	unless (sa == sspAlgorithm pk) . throw ALFatal ADHsFailure $+	unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $ 		pre ++ "sign algorithm unmatch" 	unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .-		throw ALFatal ADDecryptError $ pre ++ "verify failure"+		throw ALFtl ADDecryptErr $ pre ++ "verify failure" 	crt <- clientCertificate crts 	sv <- withRandom $ generateSecret ps 	makeKeys Client rs $ calculateShared ps sv pv-	writeHandshake . ClientKeyEx . B.encode $ calculatePublic ps sv+	writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv 	finishHandshake crt-	where pre = moduleName ++ ".succeed: "+	where pre = modNm ++ ".succeed: "  class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where 	serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g@@ -227,12 +220,12 @@  instance KeyExchangeClass ECC.Curve where 	serverKeyExchange = do-		ServerKeyExEcdhe cv pnt ha sa sn <- readHandshake+		SvKeyExEcdhe cv pnt ha sa sn <- readHandshake 		return (cv, pnt, ha, sa, sn)  instance KeyExchangeClass DH.Params where 	serverKeyExchange = do-		ServerKeyExDhe ps pv ha sa sn <- readHandshake+		SvKeyExDhe ps pv ha sa sn <- readHandshake 		return (ps, pv, ha, sa, sn)  clientCertificate :: (HandleLike h, CPRG g) =>@@ -245,7 +238,7 @@ 		case find (isMatchedCert cct a dn) crts of 			Just c -> 				(>>) <$> writeHandshake . snd <*> return . Just $ c-			_ -> throw ALFatal ADUnknownCa $ moduleName +++			_ -> throw ALFtl ADUnkCa $ modNm ++ 				".clientCertificate: no certificate"  isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] ->@@ -259,7 +252,7 @@ 	ccrt (X509.CertificateChain cs@(c : _)) = 		cpk (X509.certPubKey $ obj c) && 		not (null . intersect dn $ map (X509.certIssuerDN . obj) cs)-	ccrt _ = error $ moduleName ++ ".isMatchedCert: empty certificate chain"+	ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain" 	cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False  finishHandshake :: (HandleLike h, CPRG g) =>@@ -268,15 +261,15 @@ 	hs <- handshakeHash 	case fst <$> crt of 		Just (RsaKey sk) -> writeHandshake $-			DigitallySigned (cssAlgorithm sk) $ csSign sk hs+			DigitSigned (cssAlgorithm sk) $ csSign sk hs 		Just (EcdsaKey sk) -> writeHandshake $-			DigitallySigned (cssAlgorithm sk) $ csSign sk hs+			DigitSigned (cssAlgorithm sk) $ csSign sk hs 		_ -> return ()-	writeHandshake ChangeCipherSpec+	writeHandshake CCSpec 	flushCipherSuite Write 	writeHandshake =<< finishedHash Client-	ChangeCipherSpec <- readHandshake+	CCSpec <- readHandshake 	flushCipherSuite Read 	(==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless-		(throw ALFatal ADDecryptError $-			moduleName ++ ".finishHandshake: finished hash failure")+		(throw ALFtl ADDecryptErr $+			modNm ++ ".finishHandshake: finished hash failure")

@@ -0,0 +1,236 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec (+	Handshake(..), HandshakeItem(..),+	ClHello(..), SvHello(..), SssnId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), Extension(..), isRnInfo, emptyRnInfo,+	SvKeyEx(..), SvKeyExDhe(..), SvKeyExEcdhe(..),+	CertReq(..), certReq, ClCertType(..), SignAlg(..), HashAlg(..),+	SHDone(..), ClKeyEx(..), Epms(..),+	DigitSigned(..), Finished(..),+	CCSpec(..), ) 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.Codec.Hello (+	ClHello(..), SvHello(..), SssnId(..),+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	CmpMtd(..), HashAlg(..), SignAlg(..),+	Extension(..), isRnInfo, emptyRnInfo )+import Network.PeyoTLS.Codec.Certificate (+	CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..) )++modNm :: String+modNm = "Network.PeyoTLS.Types"++data Handshake+	= HCCSpec                     | HHelloReq+	| HClHello ClHello            | HSvHello SvHello+	| HCert X509.CertificateChain | HSvKeyEx BS.ByteString+	| HCertReq CertReq            | HSHDone+	| HCertVer DigitSigned        | HClKeyEx ClKeyEx+	| 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 = (,) <$> B.take 1 <*> B.take 3 >>= \(t, l) -> case t of+		THelloReq -> const HHelloReq <$>+			unless (l == 0) (fail $ modNm ++ ": Handshake.parse")+		TClHello -> HClHello <$> B.take l+		TSvHello -> HSvHello <$> B.take l+		TCert -> HCert <$> B.take l+		TSvKeyEx -> HSvKeyEx <$> B.take l+		TCertReq -> HCertReq <$> B.take l+		TSHDone -> const HSHDone <$>+			unless (l == 0) (fail $ modNm ++ ": Handshake.parse")+		TCertVer -> HCertVer <$> B.take l+		TClKeyEx -> HClKeyEx <$> B.take l+		TFinished -> HFinished <$> B.take l+		_ -> HRaw t <$> B.take l++encodeH :: Handshake -> BS.ByteString+encodeH HHelloReq = encodeH $ HRaw THelloReq ""+encodeH (HClHello ch) = encodeH . HRaw TClHello $ B.encode ch+encodeH (HSvHello sh) = encodeH . HRaw TSvHello $ B.encode sh+encodeH (HCert crts) = encodeH . HRaw TCert $ B.encode crts+encodeH (HSvKeyEx ske) = encodeH $ HRaw TSvKeyEx ske+encodeH (HCertReq cr) = encodeH . HRaw TCertReq $ B.encode cr+encodeH HSHDone = encodeH $ HRaw TSHDone ""+encodeH (HCertVer ds) = encodeH . HRaw TCertVer $ B.encode ds+encodeH (HClKeyEx epms) = encodeH . HRaw TClKeyEx $ B.encode epms+encodeH (HFinished bs) = encodeH $ HRaw TFinished bs+encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen w24 bs+encodeH HCCSpec = B.encode CCSpec++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++data CCSpec = CCSpec | CCSpecRaw Word8 deriving Show++instance HandshakeItem CCSpec where+	fromHandshake HCCSpec = Just CCSpec+	fromHandshake _ = Nothing+	toHandshake CCSpec = HCCSpec+	toHandshake (CCSpecRaw _) = error $ modNm ++ ": CCSpec.toHandshake"++instance B.Bytable CCSpec where+	decode bs = case BS.unpack bs of+		[1] -> Right CCSpec+		[w] -> Right $ CCSpecRaw w+		_ -> Left $ modNm ++ ": CCSpec.decode"+	encode CCSpec = BS.pack [1]+	encode (CCSpecRaw w) = BS.pack [w]++instance HandshakeItem ClHello where+	fromHandshake (HClHello ch) = Just ch+	fromHandshake _ = Nothing+	toHandshake = HClHello++instance HandshakeItem SvHello where+	fromHandshake (HSvHello sh) = Just sh+	fromHandshake _ = Nothing+	toHandshake = HSvHello++instance HandshakeItem X509.CertificateChain where+	fromHandshake (HCert cc) = Just cc+	fromHandshake _ = Nothing+	toHandshake = HCert++data SvKeyEx = SvKeyEx BS.ByteString BS.ByteString HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyEx where+	fromHandshake = undefined+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyEx where+	decode = undefined+	encode (SvKeyEx ps pv h s sn) = BS.concat [+		ps, pv, B.encode h, B.encode s, B.addLen w16 sn ]++data SvKeyExDhe = SvKeyExDhe DH.Params DH.PublicNumber HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyExDhe where+	fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyExDhe where+	encode (SvKeyExDhe ps pn h s sn) = BS.concat [+		B.encode ps, B.encode pn, B.encode h, B.encode s, B.addLen w16 sn ]+	decode = B.evalBytableM B.parse++instance B.Parsable SvKeyExDhe where+	parse = SvKeyExDhe <$> B.parse <*> B.parse+		<*> B.parse <*> B.parse <*> (B.take =<< B.take 2)++data SvKeyExEcdhe = SvKeyExEcdhe ECC.Curve ECC.Point HashAlg SignAlg BS.ByteString+	deriving Show++instance HandshakeItem SvKeyExEcdhe where+	fromHandshake (HSvKeyEx ske) = either (const Nothing) Just $ B.decode ske+	fromHandshake _ = Nothing+	toHandshake = HSvKeyEx . B.encode++instance B.Bytable SvKeyExEcdhe where+	encode (SvKeyExEcdhe cv pnt h s sn) = BS.concat [+		B.encode cv, B.encode pnt, B.encode h, B.encode s, B.addLen w16 sn ]+	decode = B.evalBytableM B.parse++instance B.Parsable SvKeyExEcdhe where+	parse = SvKeyExEcdhe <$> B.parse <*> B.parse+		<*> B.parse <*> B.parse <*> (B.take =<< B.take 2)++instance HandshakeItem CertReq where+	fromHandshake (HCertReq cr) = Just cr+	fromHandshake _ = Nothing+	toHandshake = HCertReq++data SHDone = SHDone deriving Show++instance HandshakeItem SHDone where+	fromHandshake HSHDone = Just SHDone+	fromHandshake _ = Nothing+	toHandshake _ = HSHDone++instance HandshakeItem DigitSigned where+	fromHandshake (HCertVer ds) = Just ds+	fromHandshake _ = Nothing+	toHandshake = HCertVer++instance HandshakeItem ClKeyEx where+	fromHandshake (HClKeyEx cke) = Just cke+	fromHandshake _ = Nothing+	toHandshake = HClKeyEx++data Epms = Epms BS.ByteString++instance HandshakeItem Epms where+	fromHandshake (HClKeyEx (ClKeyEx cke)) =+		case B.runBytableM (B.take =<< B.take 2) cke of+			Right (e, "") -> Just $ Epms e+			_ -> Nothing+	fromHandshake _ = Nothing+	toHandshake (Epms epms) = HClKeyEx . ClKeyEx $ B.addLen w16 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 Type+	= THelloReq | TClHello | TSvHello  | TCert | TSvKeyEx | TCertReq | TSHDone+	| TCertVer  | TClKeyEx | TFinished | TRaw Word8 deriving Show++instance B.Bytable Type where+	decode bs = case BS.unpack bs of+		[0] -> Right THelloReq+		[1] -> Right TClHello+		[2] -> Right TSvHello+		[11] -> Right TCert+		[12] -> Right TSvKeyEx+		[13] -> Right TCertReq+		[14] -> Right TSHDone+		[15] -> Right TCertVer+		[16] -> Right TClKeyEx+		[20] -> Right TFinished+		[ht] -> Right $ TRaw ht+		_ -> Left $ modNm ++ ": Type.decode"+	encode THelloReq = BS.pack [0]+	encode TClHello = BS.pack [1]+	encode TSvHello = BS.pack [2]+	encode TCert = BS.pack [11]+	encode TSvKeyEx = BS.pack [12]+	encode TCertReq = BS.pack [13]+	encode TSHDone = BS.pack [14]+	encode TCertVer = BS.pack [15]+	encode TClKeyEx = BS.pack [16]+	encode TFinished = BS.pack [20]+	encode (TRaw w) = BS.pack [w]++w16 :: Word16; w16 = undefined+w24 :: Word24; w24 = undefined

@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Codec.Certificate (+	CertReq(..), certReq, ClCertType(..), ClKeyEx(..), DigitSigned(..)) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)+import Data.Word.Word24 (Word24)++import qualified Data.ByteString as BS+import qualified Data.ASN1.Types as ASN1+import qualified Data.ASN1.Encoding as ASN1+import qualified Data.ASN1.BinaryEncoding as ASN1+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B++import Network.PeyoTLS.Codec.HSAlg (HashAlg, SignAlg)++modNm :: String+modNm = "Network.PeyoTLS.Codec.Certificate"++instance B.Bytable X509.CertificateChain where+	decode = B.evalBytableM B.parse+	encode = B.addLen w24 . cmap (B.addLen w24)+		. (\(X509.CertificateChainRaw c) -> c) . X509.encodeCertificateChain+		. (\(X509.CertificateChain cs) -> X509.CertificateChain cs)++instance B.Parsable X509.CertificateChain where+	parse = X509.decodeCertificateChain . X509.CertificateChainRaw <$>+			(flip B.list (B.take =<< B.take 3) =<< B.take 3) >>= \ecc ->+		case ecc of+			Right (X509.CertificateChain cs) ->+				return $ X509.CertificateChain cs+			Left (n, em) -> fail $ modNm ++ ": " +++				"X509.CertificateChain.parse" ++ show n ++ " " ++ em++data CertReq = CertReq [ClCertType] [(HashAlg, SignAlg)] [X509.DistinguishedName]+	deriving Show++certReq :: [ClCertType] -> [(HashAlg, SignAlg)] -> X509.CertificateStore -> CertReq+certReq t a = CertReq t a+	. map (X509.certIssuerDN . X509.signedObject . X509.getSigned)+	. X509.listCertificates++instance B.Bytable CertReq where+	encode (CertReq t a n) = BS.concat [+		B.addLen w8 $ cmap B.encode t,+		B.addLen w16 $+			cmap (\(h, s) -> B.encode h `BS.append` B.encode s) a,+		B.addLen w16 . flip cmap n $ B.addLen w16 .+			ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ]+	decode = B.evalBytableM $ CertReq+		<$> (flip B.list (B.take 1) =<< B.take 1)+		<*> (flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2)+		<*> ((B.take 2 >>=) . flip B.list $+			either (fail . show) (return . fst) . ASN1.fromASN1 =<<+			either (fail . show) return . ASN1.decodeASN1' ASN1.DER =<<+			B.take =<< B.take 2)++data ClCertType = CTRsaSign | CTEcdsaSign | CTRaw Word8 deriving (Show, Eq)++instance B.Bytable ClCertType where+	encode CTRsaSign = "\x01"+	encode CTEcdsaSign = "\x40"+	encode (CTRaw w) = BS.pack [w]+	decode bs = case BS.unpack bs of+		[w] -> Right $ case w of+			1 -> CTRsaSign; 64 -> CTEcdsaSign; _ -> CTRaw w+		_ -> Left $ modNm ++ ": ClCertType.decode"++data ClKeyEx = ClKeyEx BS.ByteString deriving Show+instance B.Bytable ClKeyEx where decode = Right . ClKeyEx; encode (ClKeyEx e) = e++data DigitSigned+	= DigitSigned (HashAlg, SignAlg) BS.ByteString+	| DigitSignedRaw BS.ByteString+	deriving Show++instance B.Bytable DigitSigned where+	decode = B.evalBytableM $ DigitSigned+		<$> ((,) <$> B.take 1 <*> B.take 1) <*> (B.take =<< B.take 2)+	encode (DigitSigned (ha, sa) bs) = BS.concat+		[B.encode ha, B.encode sa, B.addLen w16 bs]+	encode (DigitSignedRaw bs) = bs++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined+w24 :: Word24; w24 = undefined

@@ -0,0 +1,230 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.PeyoTLS.Codec.Extension (+	Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) ) where++import Control.Applicative ((<$>), (<*>))+import Data.Bits (shiftL, (.|.))+import Data.Word (Word8, Word16)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import Network.PeyoTLS.Codec.HSAlg(HashAlg(..), SignAlg(..))++modNm :: String+modNm = "Network.PeyoTLS.Codec.Extension"++data Extension+	= ESName [SName]+	| EECrv [ECC.CurveName]     | EEPFrmt [EPFrmt]+	| ESsnTcktTls BS.ByteString | ENxPrtNego BS.ByteString+	| ERnInfo BS.ByteString     | ERaw EType BS.ByteString+	deriving (Show, Eq)++instance B.Bytable Extension where+	encode (ESName n) = B.encode . ERaw TSName . B.addLen w16 $ cmap B.encode n+	encode (EECrv c) = B.encode . ERaw TECrv . B.addLen w16 $ cmap B.encode c+	encode (EEPFrmt f) = B.encode . ERaw TEPFrmt . B.addLen w8 $ cmap B.encode f+	encode (ESsnTcktTls t) = B.encode $ ERaw TSsnTcktTls t+	encode (ENxPrtNego n) = B.encode $ ERaw TNxPrtNego n+	encode (ERnInfo i) = B.encode . ERaw TRnInfo $ B.addLen w8 i+	encode (ERaw t e) = B.encode t `BS.append` B.addLen w16 e+	decode = B.evalBytableM B.parse++instance B.Parsable Extension where+	parse = (,) <$> B.take 2 <*> B.take 2 >>= \(t, l) -> case t of+		TSName -> ESName <$> (flip B.list B.parse =<< B.take 2)+		TECrv -> EECrv <$> (flip B.list (B.take 2) =<< B.take 2)+		TEPFrmt -> EEPFrmt <$> (flip B.list (B.take 1) =<< B.take 1)+		TSsnTcktTls -> ESsnTcktTls <$> B.take l+		TNxPrtNego -> ENxPrtNego <$> B.take l+		TRnInfo -> ERnInfo <$> (B.take =<< B.take 1)+		_ -> ERaw t <$> B.take l++cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString+cmap = (BS.concat .) . map++data EType+	= TSName     | TECrv   | TEPFrmt | TSsnTcktTls+	| TNxPrtNego | TRnInfo | TRaw Word16 deriving (Show, Eq)++instance B.Bytable EType where+	encode TSName = B.encode (0 :: Word16)+	encode TECrv = B.encode (10 :: Word16)+	encode TEPFrmt = B.encode (11 :: Word16)+	encode TSsnTcktTls = B.encode (35 :: Word16)+	encode TNxPrtNego = B.encode (13172 :: Word16)+	encode TRnInfo = B.encode (65281 :: Word16)+	encode (TRaw et) = B.encode et+	decode bs = case BS.unpack bs of+		[w1, w2] -> Right $+			case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+				0 -> TSName+				10 -> TECrv+				11 -> TEPFrmt+				35 -> TSsnTcktTls+				13172 -> TNxPrtNego+				65281 -> TRnInfo+				et -> TRaw et+		_ -> Left $ modNm ++ ": EType.decode"++data SName = SNHName BS.ByteString | SNRaw NType BS.ByteString deriving (Show, Eq)++instance B.Bytable SName where+	encode (SNHName nm) = B.encode $ SNRaw NTHName nm+	encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm+	decode = B.evalBytableM B.parse++instance B.Parsable SName where+	parse = (\t n -> case t of NTHName -> SNHName n; _ -> SNRaw t n)+		<$> B.take 1 <*> (B.take =<< B.take 2)++data NType = NTHName | NTRaw Word8 deriving (Show, Eq)++instance B.Bytable NType where+	encode NTHName = BS.pack [0]+	encode (NTRaw t) = BS.pack [t]+	decode bs = case BS.unpack bs of+		[t] -> Right $ case t of 0 -> NTHName; _ -> NTRaw t+		_ -> Left $ modNm ++ ": NType.decode"++instance B.Bytable DH.Params where+	encode (DH.Params p g) = BS.concat+		[B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g]+	decode = B.evalBytableM B.parse++instance B.Parsable DH.Params where+	parse = DH.Params <$> (B.take =<< B.take 2) <*> (B.take =<< B.take 2)++instance B.Bytable DH.PublicNumber where+	encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn+	decode = B.evalBytableM B.parse++instance B.Parsable DH.PublicNumber where+	parse = fromInteger <$> (B.take =<< B.take 2)++data ECType = ExpPrm | ExpCh2 | NmdCrv | CRaw Word8 deriving Show++instance B.Bytable ECType where+	encode ExpPrm = BS.pack [1]+	encode ExpCh2 = BS.pack [2]+	encode NmdCrv = BS.pack [3]+	encode (CRaw w) = BS.pack [w]+	decode = B.evalBytableM B.parse++instance B.Parsable ECType where+	parse = (\t -> case t of 1 -> ExpPrm; 2 -> ExpCh2; 3 -> NmdCrv; _ -> CRaw t)+		<$> B.head++instance B.Bytable ECC.CurveName where+	encode ECC.SEC_t163k1 = B.encode (1 :: Word16)+	encode ECC.SEC_t163r1 = B.encode (2 :: Word16)+	encode ECC.SEC_t163r2 = B.encode (3 :: Word16)+	encode ECC.SEC_t193r1 = B.encode (4 :: Word16)+	encode ECC.SEC_t193r2 = B.encode (5 :: Word16)+	encode ECC.SEC_t233k1 = B.encode (6 :: Word16)+	encode ECC.SEC_t233r1 = B.encode (7 :: Word16)+	encode ECC.SEC_t239k1 = B.encode (8 :: Word16)+	encode ECC.SEC_t283k1 = B.encode (9 :: Word16)+	encode ECC.SEC_t283r1 = B.encode (10 :: Word16)+	encode ECC.SEC_t409k1 = B.encode (11 :: Word16)+	encode ECC.SEC_t409r1 = B.encode (12 :: Word16)+	encode ECC.SEC_t571k1 = B.encode (13 :: Word16)+	encode ECC.SEC_t571r1 = B.encode (14 :: Word16)+	encode ECC.SEC_p160k1 = B.encode (15 :: Word16)+	encode ECC.SEC_p160r1 = B.encode (16 :: Word16)+	encode ECC.SEC_p160r2 = B.encode (17 :: Word16)+	encode ECC.SEC_p192k1 = B.encode (18 :: Word16)+	encode ECC.SEC_p192r1 = B.encode (19 :: Word16)+	encode ECC.SEC_p224k1 = B.encode (20 :: Word16)+	encode ECC.SEC_p224r1 = B.encode (21 :: Word16)+	encode ECC.SEC_p256k1 = B.encode (22 :: Word16)+	encode ECC.SEC_p256r1 = B.encode (23 :: Word16)+	encode ECC.SEC_p384r1 = B.encode (24 :: Word16)+	encode ECC.SEC_p521r1 = B.encode (25 :: Word16)+	encode _ = error "Extension.encodeCN: not implemented"+	decode bs = case BS.unpack bs of+		[w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of+			(1 :: Word16) -> Right ECC.SEC_t163k1+			(2 :: Word16) -> Right ECC.SEC_t163r1+			(3 :: Word16) -> Right ECC.SEC_t163r2+			(4 :: Word16) -> Right ECC.SEC_t193r1+			(5 :: Word16) -> Right ECC.SEC_t193r2+			(6 :: Word16) -> Right ECC.SEC_t233k1+			(7 :: Word16) -> Right ECC.SEC_t233r1+			(8 :: Word16) -> Right ECC.SEC_t239k1+			(9 :: Word16) -> Right ECC.SEC_t283k1+			(10 :: Word16) -> Right ECC.SEC_t283r1+			(11 :: Word16) -> Right ECC.SEC_t409k1+			(12 :: Word16) -> Right ECC.SEC_t409r1+			(13 :: Word16) -> Right ECC.SEC_t571k1+			(14 :: Word16) -> Right ECC.SEC_t571r1+			(15 :: Word16) -> Right ECC.SEC_p160k1+			(16 :: Word16) -> Right ECC.SEC_p160r1+			(17 :: Word16) -> Right ECC.SEC_p160r2+			(18 :: Word16) -> Right ECC.SEC_p192k1+			(19 :: Word16) -> Right ECC.SEC_p192r1+			(20 :: Word16) -> Right ECC.SEC_p224k1+			(21 :: Word16) -> Right ECC.SEC_p224r1+			(22 :: Word16) -> Right ECC.SEC_p256k1+			(23 :: Word16) -> Right ECC.SEC_p256r1+			(24 :: Word16) -> Right ECC.SEC_p384r1+			(25 :: Word16) -> Right ECC.SEC_p521r1+			n -> Left $ modNm ++ ": CurveName.decode: unknown crv: " +++				show n+		_ -> Left $ modNm ++ ": CurveName.decode: bad format"++instance B.Parsable ECC.CurveName where parse = B.take 2++instance B.Bytable ECC.Curve where+	encode c+		| c == ECC.getCurveByName ECC.SEC_p256r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p256r1+		| c == ECC.getCurveByName ECC.SEC_p384r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p384r1+		| c == ECC.getCurveByName ECC.SEC_p521r1 =+			B.encode NmdCrv `BS.append` B.encode ECC.SEC_p521r1+		| otherwise = error $ modNm ++ ": ECC.Curve.encode: not implemented"+	decode = B.evalBytableM B.parse++instance B.Parsable ECC.Curve where+	parse = (ECC.getCurveByName <$>) $ B.parse >>= \t -> case t of+		NmdCrv -> B.parse+		_ -> error $ modNm ++ ": ECC.Curve.parse: not implemented"++data EPFrmt = EPFUncomp | EPFRaw Word8 deriving (Show, Eq)++instance B.Bytable EPFrmt where+	encode EPFUncomp = BS.pack [0]+	encode (EPFRaw f) = BS.pack [f]+	decode bs = case BS.unpack bs of+		[f] -> Right $ case f of 0 -> EPFUncomp; _ -> EPFRaw f+		_ -> Left $ modNm ++ ": Bytable.decode"++instance B.Bytable ECC.Point where+	encode (ECC.Point x y) = B.addLen w8 $+		4 `BS.cons` pad 32 0 (B.encode x) `BS.append` pad 32 0 (B.encode y)+		where pad n w s = BS.replicate (n - BS.length s) w `BS.append` s+	encode ECC.PointO = error $ modNm ++ ": EC.Point.encode"+	decode = B.evalBytableM B.parse++instance B.Parsable ECC.Point where+	parse = (B.take =<< B.take 1) >>= \bs -> case BS.uncons bs of+		Just (4, xy) -> return $ let (x, y) = BS.splitAt 32 xy in ECC.Point+			(either error id $ B.decode x)+			(either error id $ B.decode y)+		_ -> fail $ modNm ++ ": ECC.Point.parse"++isRnInfo :: Extension -> Bool+isRnInfo (ERnInfo _) = True+isRnInfo _ = False++emptyRnInfo :: Extension+emptyRnInfo = ERnInfo ""++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined

@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec.HSAlg (SignAlg(..), HashAlg(..)) where++import Data.Word (Word8)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++modNm :: String+modNm = "Network.PeyoTLS.Codec.HSAlg"++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 $ modNm ++ ": HashAlg.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 $ modNm ++ ": SignAlg.decode"+instance B.Parsable SignAlg where parse = B.take 1

@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.PeyoTLS.Codec.Hello (+	ClHello(..), SvHello(..), SssnId(..),+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), SignAlg(..), HashAlg(..),+		Extension(..), isRnInfo, emptyRnInfo ) where++import Control.Applicative ((<$>), (<*>))+import Data.Word (Word8, Word16)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++import Network.PeyoTLS.Codec.Extension (+	Extension(..), isRnInfo, emptyRnInfo, SignAlg(..), HashAlg(..) )+import Network.PeyoTLS.CipherSuite (CipherSuite(..), KeyEx(..), BulkEnc(..))++modNm :: String+modNm = "Network.PeyoTLS.Codec.Hello"++data ClHello+	= ClHello (Word8, Word8) BS.ByteString SssnId [CipherSuite] [CmpMtd]+		(Maybe [Extension])+	| ClHelloRaw BS.ByteString+	deriving Show++instance B.Bytable ClHello where+	decode = B.evalBytableM $ ClHello+		<$> ((,) <$> B.head <*> B.head)+		<*> B.take 32 <*> (B.take =<< B.take 1)+		<*> (flip B.list (B.take 2) =<< B.take 2)+		<*> (flip B.list (B.take 1) =<< B.take 1)+		<*> do	nl <- B.null+			if nl then return Nothing else Just <$>+				(flip B.list B.parse =<< B.take 2)+	encode (ClHello (vj, vn) r sid css cms mel) = BS.concat [+		B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid,+		B.addLen w16 . BS.concat $ map B.encode css,+		B.addLen w8 . BS.concat $ map B.encode cms,+		maybe "" (B.addLen w16 . BS.concat . map B.encode) mel ]+	encode (ClHelloRaw bs) = bs++data SvHello+	= SvHello (Word8, Word8) BS.ByteString SssnId CipherSuite CmpMtd+		(Maybe [Extension])+	| SvHelloRaw BS.ByteString+	deriving Show++instance B.Bytable SvHello where+	decode = B.evalBytableM $ SvHello+		<$> ((,) <$> B.head <*> B.head)+		<*> B.take 32 <*> (B.take =<< B.take 1) <*> B.take 2 <*> B.take 1+		<*> do	n <- B.null+			if n then return Nothing else Just <$>+				(flip B.list B.parse =<< B.take 2)+	encode (SvHello (vj, vn) r sid cs cm mes) = BS.concat [+		B.encode vj, B.encode vn, B.encode r, B.addLen w8 $ B.encode sid,+		B.encode cs, B.encode cm,+		maybe "" (B.addLen w16 . BS.concat . map B.encode) mes ]+	encode (SvHelloRaw sh) = sh++data SssnId = SssnId BS.ByteString deriving Show++instance B.Bytable SssnId where decode = Right . SssnId; encode (SssnId bs) = bs++data CmpMtd = CmpMtdNull | CmpMtdRaw Word8 deriving (Show, Eq)++instance B.Bytable CmpMtd where+	decode bs = case BS.unpack bs of+		[cm] -> Right $ case cm of 0 -> CmpMtdNull; _ -> CmpMtdRaw cm+		_ -> Left $ modNm ++ ": CmpMtd.decode"+	encode CmpMtdNull = "\0"+	encode (CmpMtdRaw cm) = BS.pack [cm]++w8 :: Word8; w8 = undefined+w16 :: Word16; w16 = undefined

@@ -1,105 +0,0 @@-{-# LANGUAGE OverloadedStrings, PackageImports, TupleSections #-}--module Network.PeyoTLS.Crypto (-	makeKeys, encrypt, decrypt, hashSha1, hashSha256,-	Side(..), 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--data Side = Server | Client deriving (Show, Eq)--finishedHash :: Side -> BS.ByteString -> BS.ByteString -> BS.ByteString-finishedHash s ms hash = take 12 . prf ms . (`BS.append` hash) $ case s of-	Client -> "client finished"-	Server -> "server finished"--myLast :: String -> BS.ByteString -> Word8-myLast msg "" = error msg-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,220 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..)) where--import Control.Applicative ((<$>), (<*>))-import Data.Bits (shiftL, (.|.))-import Data.Word (Word8, Word16)--import qualified Data.ByteString as BS-import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.Types.PubKey.DH as DH-import qualified Crypto.Types.PubKey.ECC as ECC--import Network.PeyoTLS.HSAlg(HashAlg(..), SignAlg(..))--data Extension-	= ESName [ServerName]-	| EECurve [ECC.CurveName] | EEcPFrt [EcPointFormat]-	| ESsnTicketTls BS.ByteString-	| ENextProtoNego BS.ByteString-	| ERenegoInfo BS.ByteString-	| ERaw EType BS.ByteString-	deriving (Show, Eq)--instance B.Bytable Extension where-	encode = encodeE; decode = B.evalBytableM B.parse--instance B.Parsable Extension where-	parse = parseE--encodeE :: Extension -> BS.ByteString-encodeE (ESName sn) = encodeE . ERaw TSName . B.addLen w16 $ cmap B.encode sn-encodeE (EECurve ec) = encodeE . ERaw TECurve . B.addLen w16 $ cmap B.encode ec-encodeE (EEcPFrt pf) = encodeE . ERaw TEcPFrt . B.addLen w8 $ cmap B.encode pf-encodeE (ESsnTicketTls stt) = encodeE $ ERaw TSsnTicketTls stt-encodeE (ENextProtoNego npn) = encodeE $ ERaw TNextProtoNego npn-encodeE (ERenegoInfo ri) = encodeE . ERaw TRenegoInfo $ B.addLen w8 ri-encodeE (ERaw et body) = B.encode et `BS.append` B.addLen w16 body--parseE :: B.BytableM Extension-parseE = do-	(t, l) <- (,) <$> B.take 2 <*> B.take 2-	case t of-		TSName -> ESName <$> (flip B.list B.parse =<< B.take 2)-		TECurve -> EECurve <$> (flip B.list (B.take 2) =<< B.take 2)-		TEcPFrt -> EEcPFrt <$> (flip B.list (B.take 1) =<< B.take 1)-		TSsnTicketTls -> ESsnTicketTls <$> B.take l-		TNextProtoNego -> ENextProtoNego <$> B.take l-		TRenegoInfo -> ERenegoInfo <$> (B.take =<< B.take 1)-		_ -> ERaw t <$> B.take l--data EType-	= TSName         | TECurve     | TEcPFrt     | TSsnTicketTls-	| TNextProtoNego | TRenegoInfo | TRaw Word16 deriving (Show, Eq)--instance B.Bytable EType where-	encode TSName = B.encode (0 :: Word16)-	encode TECurve = B.encode (10 :: Word16)-	encode TEcPFrt = B.encode (11 :: Word16)-	encode TSsnTicketTls = B.encode (35 :: Word16)-	encode TNextProtoNego = B.encode (13172 :: Word16)-	encode TRenegoInfo = B.encode (65281 :: Word16)-	encode (TRaw et) = B.encode et-	decode bs = case BS.unpack bs of-		[w1, w2] -> Right $-			case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of-				0 -> TSName-				10 -> TECurve-				11 -> TEcPFrt-				35 -> TSsnTicketTls-				13172 -> TNextProtoNego-				65281 -> TRenegoInfo-				et -> TRaw et-		_ -> Left "Extension: EType.decode"--data ServerName = SNHostName BS.ByteString | SNRaw NameType BS.ByteString-	deriving (Show, Eq)--instance B.Bytable ServerName where-	encode (SNHostName nm) = B.encode $ SNRaw NTHostName nm-	encode (SNRaw nt nm) = B.encode nt `BS.append` B.addLen w16 nm-	decode = B.evalBytableM B.parse--instance B.Parsable ServerName where-	parse = do-		(t, n) <- (,) <$> B.take 1 <*> (B.take =<< B.take 2)-		return $ case t of-			NTHostName -> SNHostName n; _ -> SNRaw t n--data NameType = NTHostName | NTRaw Word8 deriving (Show, Eq)--instance B.Bytable NameType where-	encode NTHostName = BS.pack [0]-	encode (NTRaw t) = BS.pack [t]-	decode bs = case BS.unpack bs of-		[t] -> Right $ case t of 0 -> NTHostName; _ -> NTRaw t-		_ -> Left "Extension: NameType.decode"--instance B.Bytable DH.Params where-	encode (DH.Params p g) =-		BS.concat [B.addLen w16 $ B.encode p, B.addLen w16 $ B.encode g]-	decode = B.evalBytableM B.parse--instance B.Parsable DH.Params where-	parse = DH.Params-		<$> (B.take =<< B.take 2)-		<*> (B.take =<< B.take 2)--instance B.Bytable DH.PublicNumber where-	encode = B.addLen w16 . B.encode . \(DH.PublicNumber pn) -> pn-	decode = B.evalBytableM B.parse--instance B.Parsable DH.PublicNumber where-	parse = fromInteger <$> (B.take =<< B.take 2)--data EcCurveType = ExplicitPrime | ExplicitChar2 | NamedCurve | ECTRaw Word8-	deriving Show--instance B.Bytable EcCurveType where-	encode ExplicitPrime = BS.pack [1]-	encode ExplicitChar2 = BS.pack [2]-	encode NamedCurve = BS.pack [3]-	encode (ECTRaw w) = BS.pack [w]-	decode = B.evalBytableM B.parse--instance B.Parsable EcCurveType where-	parse = do-		ct <- B.head-		return $ case ct of-			1 -> ExplicitPrime-			2 -> ExplicitChar2-			3 -> NamedCurve-			w -> ECTRaw w--instance B.Bytable ECC.CurveName where-	encode ECC.SEC_t163k1 = B.encode (1 :: Word16)-	encode ECC.SEC_t163r1 = B.encode (2 :: Word16)-	encode ECC.SEC_t163r2 = B.encode (3 :: Word16)-	encode ECC.SEC_t193r1 = B.encode (4 :: Word16)-	encode ECC.SEC_t193r2 = B.encode (5 :: Word16)-	encode ECC.SEC_t233k1 = B.encode (6 :: Word16)-	encode ECC.SEC_t233r1 = B.encode (7 :: Word16)-	encode ECC.SEC_t409k1 = B.encode (11 :: Word16)-	encode ECC.SEC_t409r1 = B.encode (12 :: Word16)-	encode ECC.SEC_t571k1 = B.encode (13 :: Word16)-	encode ECC.SEC_t571r1 = B.encode (14 :: Word16)-	encode ECC.SEC_p256r1 = B.encode (23 :: Word16)-	encode ECC.SEC_p384r1 = B.encode (24 :: Word16)-	encode ECC.SEC_p521r1 = B.encode (25 :: Word16)-	encode _ = error "Extension.encodeCN: not implemented"-	decode bs = case BS.unpack bs of-		[w1, w2] -> case fromIntegral w1 `shiftL` 8 .|. fromIntegral w2 of-			(1 :: Word16) -> Right ECC.SEC_t163k1-			(2 :: Word16) -> Right ECC.SEC_t163r1-			(3 :: Word16) -> Right ECC.SEC_t163r2-			(4 :: Word16) -> Right ECC.SEC_t193r1-			(5 :: Word16) -> Right ECC.SEC_t193r2-			(6 :: Word16) -> Right ECC.SEC_t233k1-			(7 :: Word16) -> Right ECC.SEC_t233r1-			(11 :: Word16) -> Right ECC.SEC_t409k1-			(12 :: Word16) -> Right ECC.SEC_t409r1-			(13 :: Word16) -> Right ECC.SEC_t571k1-			(14 :: Word16) -> Right ECC.SEC_t571r1-			(23 :: Word16) -> Right ECC.SEC_p256r1-			(24 :: Word16) -> Right ECC.SEC_p384r1-			(25 :: Word16) -> Right ECC.SEC_p521r1-			n -> Left $ "Extension: CurveName.decode: unknown curve: " ++-				show n-		_ -> Left "Extension: CurveName.decode: bad format"--instance B.Parsable ECC.CurveName where-	parse = B.take 2--instance B.Bytable ECC.Curve where-	encode c-		| c == ECC.getCurveByName ECC.SEC_p256r1 =-			B.encode NamedCurve `BS.append` B.encode ECC.SEC_p256r1-		| otherwise = error "TlsServer.encodeC: not implemented"-	decode = B.evalBytableM B.parse--instance B.Parsable ECC.Curve where-	parse = ECC.getCurveByName <$> do-		NamedCurve <- B.parse-		B.parse--data EcPointFormat = EPFUncompressed | EPFRaw Word8 deriving (Show, Eq)--instance B.Bytable EcPointFormat where-	encode EPFUncompressed = BS.pack [0]-	encode (EPFRaw f) = BS.pack [f]-	decode bs = case BS.unpack bs of-		[f] -> Right $ case f of 0 -> EPFUncompressed; _ -> EPFRaw f-		_ -> Left "Extension: Bytable.decode"--instance B.Bytable ECC.Point where-	encode (ECC.Point x y) = B.addLen w8 $-		4 `BS.cons` padd 32 0 (B.encode x) `BS.append`-			padd 32 0 (B.encode y)-	encode ECC.PointO = error "Extension: EC.Point.encode"-	decode = B.evalBytableM B.parse--padd :: Int -> Word8 -> BS.ByteString -> BS.ByteString-padd n w s = BS.replicate (n - BS.length s) w `BS.append` s--instance B.Parsable ECC.Point where-	parse = do-		bs <- B.take =<< B.take 1-		case BS.uncons bs of-			Just (4, rest) -> return $ let (x, y) = BS.splitAt 32 rest in-				ECC.Point-					(either error id $ B.decode x)-					(either error id $ B.decode y)-			_ -> fail "Extension: ECC.Point.parse"--w8 :: Word8; w8 = undefined-w16 :: Word16; w16 = undefined--cmap :: (a -> BS.ByteString) -> [a] -> BS.ByteString-cmap = (BS.concat .) . map

@@ -1,42 +0,0 @@-{-# 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

@@ -1,496 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}--module Network.PeyoTLS.Handle ( debug,-	M.TlsM, run, M.withRandom,-	TlsHandleBase(names), M.CipherSuite,-		newHandle, chGet, ccsPut, hsPut,-		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,-		flushAd, getBuf, setBuf,-		getCipherSuite, setCipherSuite,-		M.SettingsC, getSettingsC, setSettingsC,-		M.SettingsS, getSettingsS, setSettingsS,-		getClFinished, getSvFinished, setClFinished, setSvFinished,-		makeKeys, setKeys,-		getNames, setNames,-		C.Side(..), finishedHash,-		M.RW(..), flushCipherSuite,-	ValidateHandle(..), tValidate,-	M.CertSecretKey(..), M.isRsaKey, M.isEcdsaKey,-	M.Alert(..), M.AlertLevel(..), M.AlertDesc(..), debugCipherSuite ) where--import Control.Arrow (second)-import Control.Monad (when, unless, liftM)-import "monads-tf" Control.Monad.State (lift, get, put)-import "monads-tf" Control.Monad.Error (catchError, throwError)-import Data.Word (Word8, Word16, Word64)-import Data.HandleLike (HandleLike(..))-import System.IO (Handle)-import "crypto-random" Crypto.Random (CPRG)--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.X509 as X509-import qualified Data.X509.Validation as X509-import qualified Data.X509.CertificateStore as X509-import qualified Codec.Bytable.BigEndian as B--import qualified Network.PeyoTLS.Monad as M (-	TlsM, evalTlsM, initState, withRandom,-		Alert(..), AlertLevel(..), AlertDesc(..),-		tGet, tPut, tClose, tDebug,-	PartnerId, newPartnerId, ContentType(..),-		getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,-		getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn,-		getClFinished, getSvFinished, setClFinished, setSvFinished,-		getNames, setNames,-	CipherSuite(..), BulkEnc(..), CertSecretKey(..), isRsaKey, isEcdsaKey,-		SettingsC, getSettingsC, setSettingsC,-		SettingsS, getSettingsS, setSettingsS,-		RW(..), getCipherSuite, setCipherSuite, flushCipherSuite,-	Keys(..), getKeys, setKeys )-import qualified Network.PeyoTLS.Crypto as C (-	makeKeys, encrypt, decrypt, hashSha1, hashSha256,-	Side(..), finishedHash )--class HandleLike h => ValidateHandle h where-	validate :: h -> X509.CertificateStore -> X509.CertificateChain ->-		HandleMonad h [X509.FailedReason]--tValidate :: ValidateHandle h =>-	TlsHandleBase h g -> X509.CertificateStore -> X509.CertificateChain ->-	M.TlsM h g [X509.FailedReason]-tValidate t cs cc = lift . lift $ validate (tlsHandle t) cs cc--instance ValidateHandle Handle where-	validate _ cs cc =-		X509.validate X509.HashSHA256 X509.defaultHooks ch cs ca ("", "") cc-		where-		ch = X509.defaultChecks { X509.checkFQHN = False }-		ca = X509.ValidationCache-			(\_ _ _ -> return X509.ValidationCacheUnknown)-			(\_ _ _ -> return ())--data TlsHandleBase h g = TlsHandleBase {-	partnerId :: M.PartnerId,-	tlsHandle :: h,-	names :: [String] }-	deriving Show--run :: HandleLike h => M.TlsM h g a -> g -> HandleMonad h a-run m g = do-	ret <- (`M.evalTlsM` M.initState g) $ m `catchError` \a -> throwError a-	case ret of-		Right r -> return r-		Left a -> error $ show a--newHandle :: HandleLike h => h -> M.TlsM h g (TlsHandleBase h g)-newHandle h = do-	s <- get-	let (i, s') = M.newPartnerId s-	put s'-	return TlsHandleBase {-		partnerId = i, tlsHandle = h, names = [] }--getContentType :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g M.ContentType-getContentType t = do-	(ct, bs) <- M.getRBuf (partnerId t)-	(\gt -> case (ct, bs) of (M.CTNull, _) -> gt; (_, "") -> gt; _ -> return ct) $-		do	(ct', bf) <- getWholeWithCt t-			M.setRBuf (partnerId t) (ct', bf)-			return ct'--flushAd :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> M.TlsM h g (BS.ByteString, Bool)-flushAd t = do-	lift . lift $ hlDebug (tlsHandle t) "low" "begin flushAd\n"-	ct <- getContentType t-	lift . lift $ hlDebug (tlsHandle t) "low" "after getContentType\n"-	case ct of-		M.CTAppData -> do-			lift . lift $ hlDebug (tlsHandle t) "low" "CTAppData\n"-			(ct', ad) <- tGetContent t-			lift . lift $ hlDebug (tlsHandle t) "low" .-				BSC.pack $ show (ct', ad) ++ "\n"-			(bs, b) <- flushAd t-			lift . lift . hlDebug (tlsHandle t) "low" .-				BSC.pack $ show bs-			return (ad `BS.append` bs, b)-		M.CTAlert -> do-			(_, a) <- buffered t 2-			lift . lift $ hlDebug (tlsHandle t) "low" .-				BSC.pack $ show a-			case a of-				"\1\0" -> return ("", False)-				_ -> throwError "flushAd"-		_ -> do	lift . lift $ hlDebug (tlsHandle t) "low" .-				BSC.pack $ show ct-			return ("", True)--chGet :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> Int -> M.TlsM h g (Either Word8 BS.ByteString)-chGet _ 0 = return $ Right ""-chGet t n = do-	lift . lift . hlDebug (tlsHandle t) "critical" .-		BSC.pack . (++ "\n") $ show n-	ct <- getContentType t-	lift . lift . hlDebug (tlsHandle t) "critical" .-		BSC.pack . (++ "\n") $ show ct-	case ct of-		M.CTCCSpec -> do-			(M.CTCCSpec, bs) <- buffered t 1-			resetSequenceNumber t M.Read-			return . Left . (\[w] -> w) $ BS.unpack bs-		M.CTHandshake -> do-			(M.CTHandshake, bs) <- buffered t n-			return $ Right bs-		M.CTAlert -> do-			(M.CTAlert, al) <- buffered t 2-			throw M.ALFatal M.ADUnclasified $ show al-		_ -> throwError "not handshake"--buffered :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> Int -> M.TlsM h g (M.ContentType, BS.ByteString)-buffered t n = do-	(ct, b) <- M.getRBuf $ partnerId t; let rl = n - BS.length b-	if rl <= 0-	then splitRetBuf t n ct b-	else do	(ct', b') <- getWholeWithCt t-		unless (ct' == ct) . throw M.ALFatal M.ADUnclasified $-			"Content Type confliction\n" ++-				"\tExpected: " ++ show ct ++ "\n" ++-				"\tActual  : " ++ show ct' ++ "\n" ++-				"\tData    : " ++ show b'-		when (BS.null b') $ throwError "buffered: No data available"-		M.setRBuf (partnerId t) (ct', b')-		second (b `BS.append`) `liftM` buffered t rl--adGet :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->-	TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString-adGet rn t n = buffered_ rn t n--buffered_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->-	TlsHandleBase h g -> Int -> M.TlsM h g BS.ByteString-buffered_ rn t n = do-	ct0 <- getContentType t-	case ct0 of-		M.CTHandshake -> rn t >> buffered_ rn t n-		M.CTAlert -> do-			(M.CTAlert, b) <- M.getRBuf $ partnerId t-			let rl = 2 - BS.length b-			al <- if rl <= 0-				then snd `liftM` splitRetBuf t 2 M.CTAlert b-				else do (ct', b') <- getWholeWithCt t-					unless (ct' == M.CTAlert) $ throw-						M.ALFatal M.ADUnclasified-						"Content Type confliction\n"-					when (BS.null b') $ throwError "buffered: No data"-					M.setRBuf (partnerId t) (ct', b')-					(b `BS.append`) `liftM` buffered_ rn t rl-			case al of-				"\SOH\NULL" -> do-					tlsPut t M.CTAlert "\SOH\NULL"-					throw M.ALFatal M.ADUnclasified "EOF"-				_ -> throw M.ALFatal M.ADUnclasified $-					"Alert: " ++ show al-		_ -> do	(ct, b) <- M.getRBuf $ partnerId t; let rl = n - BS.length b-			if rl <= 0-			then snd `liftM` splitRetBuf t n ct b-			else do-				(ct', b') <- getWholeWithCt t-				unless (ct' == ct) $ throw M.ALFatal M.ADUnclasified-					"Content Type confliction\n"-				when (BS.null b') $ throwError "buffered: No data"-				M.setRBuf (partnerId t) (ct', b')-				(b `BS.append`) `liftM` buffered_ rn t rl--splitRetBuf :: HandleLike h =>-	TlsHandleBase h g -> Int -> M.ContentType -> BS.ByteString ->-	M.TlsM h g (M.ContentType, BS.ByteString)-splitRetBuf t n ct b = do-	let (ret, b') = BS.splitAt n b-	M.setRBuf (partnerId t) $ if BS.null b' then (M.CTNull, "") else (ct, b')-	return (ct, ret)--getWholeWithCt :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> M.TlsM h g (M.ContentType, BS.ByteString)-getWholeWithCt t = do-	flush t-	ct <- (either (throw M.ALFatal M.ADUnclasified) return . B.decode) =<< rd 1-	[_vmj, _vmn] <- BS.unpack `liftM` rd 2-	e <- rd =<< either (throw M.ALFatal M.ADUnclasified) return . B.decode =<< rd 2-	when (BS.null e) $ throwError "TlsHandleBase.getWholeWithCt: e is null"-	p <- decrypt t ct e-	M.tDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct-	M.tDebug (tlsHandle t) "medium" . BSC.pack . (++  "\n") . show $ BS.head p-	M.tDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p-	return (ct, p)-	where rd n = do-		r <- M.tGet (tlsHandle t) n-		unless (BS.length r == n) . throw M.ALFatal M.ADUnclasified $-			"TlsHandleBase.rd: can't read " ++ show (BS.length r) ++ " " ++ show n-		return r--decrypt :: HandleLike h =>-	TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString-decrypt t ct e = do-	ks <- M.getKeys $ partnerId t-	decrypt_ t ks ct e--decrypt_ :: HandleLike h => TlsHandleBase h g ->-	M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString-decrypt_ _ M.Keys{ M.kReadCS = M.CipherSuite _ M.BE_NULL } _ e = return e-decrypt_ t ks ct e = do-	let	M.CipherSuite _ be = M.kReadCS ks-		wk = M.kReadKey ks-		mk = M.kReadMacKey ks-	sn <- updateSequenceNumber t M.Read-	hs <- case be of-		M.AES_128_CBC_SHA -> return C.hashSha1-		M.AES_128_CBC_SHA256 -> return C.hashSha256-		_ -> throwError "TlsHandleBase.decrypt: not implement bulk encryption"-	either (throw M.ALFatal M.ADUnclasified) return $-		C.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e--tlsPut :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g ()-tlsPut t ct p = do-	(bct, bp) <- M.getWBuf $ partnerId t-	case ct of-		M.CTCCSpec -> flush t >> M.setWBuf (partnerId t) (ct, p) >> flush t-		_	| bct /= M.CTNull && ct /= bct ->-				flush t >> M.setWBuf (partnerId t) (ct, p)-			| otherwise -> M.setWBuf (partnerId t) (ct, bp `BS.append` p)--flush :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g ()-flush t = do-	(bct, bp) <- M.getWBuf $ partnerId t-	M.setWBuf (partnerId t) (M.CTNull, "")-	unless (bct == M.CTNull) $ do-		e <- encrypt t bct bp-		M.tPut (tlsHandle t) $ BS.concat [-			B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ]--encrypt :: (HandleLike h, CPRG g) =>-	TlsHandleBase h g -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString-encrypt t ct p = do-	ks <- M.getKeys $ partnerId t-	encrypt_ t ks ct p--encrypt_ :: (HandleLike h, CPRG g) => TlsHandleBase h g ->-	M.Keys -> M.ContentType -> BS.ByteString -> M.TlsM h g BS.ByteString-encrypt_ _ M.Keys{ M.kWriteCS = M.CipherSuite _ M.BE_NULL } _ p = return p-encrypt_ t ks ct p = do-	let	M.CipherSuite _ be = M.kWriteCS ks-		wk = M.kWriteKey ks-		mk = M.kWriteMacKey ks-	sn <- updateSequenceNumber t M.Write-	hs <- case be of-		M.AES_128_CBC_SHA -> return C.hashSha1-		M.AES_128_CBC_SHA256 -> return C.hashSha256-		_ -> throwError "TlsHandleBase.encrypt: not implemented bulk encryption"-	M.withRandom $ C.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p--updateSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g Word64-updateSequenceNumber t rw = do-	ks <- M.getKeys $ partnerId t-	(sn, cs) <- case rw of-		M.Read -> (, M.kReadCS ks) `liftM` M.getRSn (partnerId t)-		M.Write -> (, M.kWriteCS ks) `liftM` M.getWSn (partnerId t)-	case cs of-		M.CipherSuite _ M.BE_NULL -> return ()-		_ -> case rw of-			M.Read -> M.sccRSn $ partnerId t-			M.Write -> M.sccWSn $ partnerId t-	return sn--resetSequenceNumber :: HandleLike h => TlsHandleBase h g -> M.RW -> M.TlsM h g ()-resetSequenceNumber t rw = case rw of-	M.Read -> M.rstRSn $ partnerId t-	M.Write -> M.rstWSn $ partnerId t--makeKeys :: HandleLike h =>-	TlsHandleBase h g -> C.Side -> BS.ByteString -> BS.ByteString ->-	BS.ByteString -> M.CipherSuite -> M.TlsM h g M.Keys-makeKeys t p cr sr pms cs = do-	let M.CipherSuite _ be = cs-	kl <- case be of-		M.AES_128_CBC_SHA -> return 20-		M.AES_128_CBC_SHA256 -> return 32-		_ -> throwError-			"TlsServer.makeKeys: not implemented bulk encryption"-	let	(ms, cwmk, swmk, cwk, swk) = C.makeKeys kl cr sr pms-	k <- M.getKeys $ partnerId t-	return $ case p of-		C.Client -> k {-			M.kCachedCS = cs,-			M.kMasterSecret = ms,-			M.kCachedReadMacKey = swmk, M.kCachedWriteMacKey = cwmk,-			M.kCachedReadKey = swk, M.kCachedWriteKey = cwk }-		C.Server -> k {-			M.kCachedCS = cs,-			M.kMasterSecret = ms,-			M.kCachedReadMacKey = cwmk, M.kCachedWriteMacKey = swmk,-			M.kCachedReadKey = cwk, M.kCachedWriteKey = swk }--flushCipherSuite :: HandleLike h => M.RW -> TlsHandleBase h g -> M.TlsM h g ()-flushCipherSuite rw = M.flushCipherSuite rw . partnerId--debugCipherSuite :: HandleLike h => TlsHandleBase h g -> String -> M.TlsM h g ()-debugCipherSuite t a = do-	k <- M.getKeys $ partnerId t-	M.tDebug (tlsHandle t) "high" . BSC.pack-		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50-		. show $ M.kCachedCS k-	where lenSpace n str = str ++ replicate (n - length str) ' '--finishedHash :: HandleLike h =>-	C.Side -> TlsHandleBase h g -> BS.ByteString -> M.TlsM h g BS.ByteString-finishedHash s t hs = do-	ms <- M.kMasterSecret `liftM` M.getKeys (partnerId t)-	return $ C.finishedHash s ms hs--adPut, hlPut_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()-adPut = hlPut_-hlPut_ = ((>> return ()) .) . flip tlsPut M.CTAppData--adDebug, hlDebug_ :: HandleLike h =>-	TlsHandleBase h g -> DebugLevel h -> BS.ByteString -> M.TlsM h g ()-adDebug = hlDebug_-hlDebug_ = M.tDebug . tlsHandle--adClose, hlClose_ :: (HandleLike h, CPRG g) => TlsHandleBase h g -> M.TlsM h g ()-adClose = hlClose_-hlClose_ t = tlsPut t M.CTAlert "\SOH\NUL" >> flush t >> M.tClose (tlsHandle t)--adGetLine, tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandleBase h g -> M.TlsM h g ()) ->-	TlsHandleBase h g -> M.TlsM h g BS.ByteString-adGetLine = tGetLine_-tGetLine_ rn t = do-	ct <- getContentType t-	case ct of-		M.CTHandshake -> rn t >> tGetLine_ rn t-		M.CTAlert -> do-			(M.CTAlert, b) <- M.getRBuf $ partnerId t-			let rl = 2 - BS.length b-			al <- if rl <= 0-				then snd `liftM` splitRetBuf t 2 M.CTAlert b-				else do (ct', b') <- getWholeWithCt t-					unless (ct' == M.CTAlert) . throw M.ALFatal M.ADUnclasified $-						"Content Type confliction\n"-					when (BS.null b') $ throwError "buffered: No data"-					M.setRBuf (partnerId t) (ct', b')-					(b `BS.append`) `liftM` buffered_ rn t rl-			case al of-				"\SOH\NULL" -> do-					tlsPut t M.CTAlert "\SOH\NULL"-					throw M.ALFatal M.ADUnclasified "EOF"-				_ -> throw M.ALFatal M.ADUnclasified $-					"Alert: " ++ show al-		_ -> do	(bct, bp) <- M.getRBuf $ partnerId t-			case splitLine bp of-				Just (l, ls) -> do-					M.setRBuf (partnerId t) (if BS.null ls then M.CTNull else bct, ls)-					return l-				_ -> do	cp <- getWholeWithCt t-					M.setRBuf (partnerId t) cp-					(bp `BS.append`) `liftM` tGetLine_ rn t--splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)-splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of-	(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) =>-	TlsHandleBase h g -> M.TlsM h g (M.ContentType, BS.ByteString)-tGetContent t = do-	bcp@(_, bp) <- M.getRBuf $ partnerId t-	if BS.null bp then getWholeWithCt t else-		M.setRBuf (partnerId t) (M.CTNull, BS.empty) >> return bcp--getClFinished, getSvFinished ::-	HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString-getClFinished = M.getClFinished . partnerId-getSvFinished = M.getSvFinished . partnerId--setClFinished, setSvFinished ::-	HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()-setClFinished = M.setClFinished . partnerId-setSvFinished = M.setSvFinished . partnerId--getSettingsS :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsS-getSettingsS = M.getSettingsS . partnerId--setSettingsS :: HandleLike h => TlsHandleBase h g -> M.SettingsS -> M.TlsM h g ()-setSettingsS = M.setSettingsS . partnerId--getBuf :: HandleLike h => TlsHandleBase h g -> M.TlsM h g BS.ByteString-getBuf = M.getAdBuf . partnerId--setBuf :: HandleLike h => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()-setBuf = M.setAdBuf . partnerId--adGetContent, tGetContent_ :: (HandleLike h, CPRG g) =>-	(TlsHandleBase h g -> M.TlsM h g ()) ->-	TlsHandleBase h g -> M.TlsM h g BS.ByteString-adGetContent = tGetContent_-tGetContent_ rn t = do-	ct <- getContentType t-	case ct of-		M.CTHandshake -> rn t >> tGetContent_ rn t-		M.CTAlert -> do-			(M.CTAlert, al) <- buffered t 2-			case al of-				"\SOH\NULL" -> do-					tlsPut t M.CTAlert "\SOH\NUL"-					throw M.ALFatal M.ADUnclasified $-						".checkAppData: EOF"-				_ -> throw M.ALFatal M.ADUnclasified $-					"Alert: " ++ show al-		_ -> snd `liftM` tGetContent t--hsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> BS.ByteString -> M.TlsM h g ()-hsPut = flip tlsPut M.CTHandshake--ccsPut :: (HandleLike h, CPRG g) => TlsHandleBase h g -> Word8 -> M.TlsM h g ()-ccsPut t w = do-	ret <- tlsPut t M.CTCCSpec $ BS.pack [w]-	resetSequenceNumber t M.Write-	return ret--getSettingsC :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.SettingsC-getSettingsC = M.getSettingsC . partnerId--setSettingsC :: HandleLike h => TlsHandleBase h g ->-	M.SettingsC -> M.TlsM h g ()-setSettingsC = M.setSettingsC . partnerId--getCipherSuite :: HandleLike h => TlsHandleBase h g -> M.TlsM h g M.CipherSuite-getCipherSuite = M.getCipherSuite . partnerId--setCipherSuite :: HandleLike h => TlsHandleBase h g -> M.CipherSuite -> M.TlsM h g ()-setCipherSuite = M.setCipherSuite . partnerId--getNames :: HandleLike h => TlsHandleBase h g -> M.TlsM h g [String]-getNames = M.getNames . partnerId--setNames :: HandleLike h => TlsHandleBase h g -> [String] -> M.TlsM h g ()-setNames = M.setNames . partnerId--setKeys :: HandleLike h => TlsHandleBase h g -> M.Keys -> M.TlsM h g ()-setKeys = M.setKeys . partnerId--throw :: HandleLike h => M.AlertLevel -> M.AlertDesc -> String -> M.TlsM h g a-throw = ((throwError .) .) . M.Alert--debug :: (HandleLike h, Show a) =>-	TlsHandleBase h g -> DebugLevel h -> a -> M.TlsM h g ()-debug t l x = lift . lift . hlDebug (tlsHandle t) l .-	BSC.pack . (++ "\n") $ show x

@@ -1,94 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.PeyoTLS.Hello ( Extension(..),-	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..),-		SignAlg(..), HashAlg(..) ) where--import Control.Applicative ((<$>), (<*>))-import Data.Word (Word8, Word16)-import Numeric (showHex)--import qualified Data.ByteString as BS-import qualified Codec.Bytable.BigEndian as B--import Network.PeyoTLS.Extension (Extension(..), SignAlg(..), HashAlg(..))-import Network.PeyoTLS.CipherSuite (-	CipherSuite(..), KeyEx(..), BulkEnc(..))--data ClientHello-	= ClientHello (Word8, Word8) BS.ByteString SessionId-		[CipherSuite] [CompMethod] (Maybe [Extension])-	| ClientHelloRaw BS.ByteString-	deriving Show--instance B.Bytable ClientHello where-	decode = B.evalBytableM $ do-		(pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head)-			<*> B.take 32 <*> (B.take =<< B.take 1)-		cs <- flip B.list (B.take 2) =<< B.take 2-		cm <- flip B.list (B.take 1) =<< B.take 1-		nl <- B.null-		me <- if nl then return Nothing else-			Just <$> (flip B.list B.parse =<< B.take 2)-		return $ ClientHello pv r sid cs cm me-	encode = encodeCh--encodeCh :: ClientHello -> BS.ByteString-encodeCh (ClientHello (vmjr, vmnr) r sid css cms mel) = BS.concat [-	B.encode vmjr, B.encode vmnr, B.encode r,-	B.addLen (undefined :: Word8) $ B.encode sid,-	B.addLen (undefined :: Word16) . BS.concat $ map B.encode css,-	B.addLen (undefined :: Word8) . BS.concat $ map B.encode cms,-	maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mel ]-encodeCh (ClientHelloRaw bs) = bs--data ServerHello-	= ServerHello (Word8, Word8) BS.ByteString SessionId-		CipherSuite CompMethod (Maybe [Extension])-	| ServerHelloRaw BS.ByteString-	deriving Show--instance B.Bytable ServerHello where-	decode = B.evalBytableM $ do-		(pv, r, sid) <- (,,) <$> ((,) <$> B.head <*> B.head)-			<*> B.take 32 <*> (B.take =<< B.take 1)-		cs <- B.take 2-		cm <- B.take 1-		e <- B.null-		me <- if e then return Nothing else do-			mel <- B.take 2-			Just <$> B.list mel B.parse-		return $ ServerHello pv r sid cs cm me-	encode = encodeSh--encodeSh :: ServerHello -> BS.ByteString-encodeSh (ServerHello (vmjr, vmnr) r sid cs cm mes) = BS.concat [-	B.encode vmjr, B.encode vmnr, B.encode r,-	B.addLen (undefined :: Word8) $ B.encode sid,-	B.encode cs, B.encode cm,-	maybe "" (B.addLen (undefined :: Word16) . BS.concat . map B.encode) mes ]-encodeSh (ServerHelloRaw sh) = sh--data CompMethod = CompMethodNull | CompMethodRaw Word8-	deriving (Show, Eq)--instance B.Bytable CompMethod where-	decode bs = case BS.unpack bs of-		[cm] -> Right $ case cm of-			0 -> CompMethodNull-			_ -> CompMethodRaw cm-		_ -> Left "Hello.decodeCm"-	encode CompMethodNull = "\0"-	encode (CompMethodRaw cm) = BS.pack [cm]--data SessionId = SessionId BS.ByteString--instance Show SessionId where-	show (SessionId sid) = "(SessionID " ++-		concatMap (`showHex` "") (BS.unpack sid) ++ ")"--instance B.Bytable SessionId where-	decode = Right . SessionId-	encode (SessionId bs) = bs

@@ -1,176 +0,0 @@-{-# LANGUAGE OverloadedStrings, PackageImports #-}--module Network.PeyoTLS.Monad (-	TlsM, evalTlsM, S.initState,-		tGet, tPut, tClose, tDebug, thlError,-		withRandom,-		getRBuf, setRBuf, getWBuf, setWBuf,-		getAdBuf, setAdBuf,-		getRSn, getWSn, sccRSn, sccWSn, rstRSn, rstWSn,-		getCipherSuite, setCipherSuite,-		getNames, setNames,-		setKeys, getKeys,-		S.SettingsS, getSettingsS, setSettingsS,-	S.Alert(..), S.AlertLevel(..), S.AlertDesc(..),-	S.ContentType(..),-	S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..),-	S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys,--	getClFinished, setClFinished,-	getSvFinished, setSvFinished,-	S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey,--	SettingsC, getSettingsC, setSettingsC,-	RW(..),-	flushCipherSuite,-	) where--import Control.Arrow ((***))-import Control.Monad (liftM)-import "monads-tf" Control.Monad.Trans (lift)-import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify)-import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError)-import Data.Word (Word64)-import Data.HandleLike (HandleLike(..))--import qualified Data.ByteString as BS-import qualified Data.X509 as X509-import qualified Data.X509.CertificateStore as X509--import qualified Network.PeyoTLS.State as S (-	HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,-	ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),-	CipherSuite(..), KeyEx(..), BulkEnc(..),-	randomGen, setRandomGen,-	setBuf, getBuf, setWBuf, getWBuf,-	setAdBuf, getAdBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN,-	getCipherSuite, setCipherSuite,-	setNames, getNames,-	setKeys, getKeys,-	getSettings, setSettings,-	getInitSet, setInitSet,-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,--	flushCipherSuiteRead, flushCipherSuiteWrite,--	SettingsS, Settings,-	CertSecretKey(..), isRsaKey, isEcdsaKey,-	)--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--getRBuf, getWBuf ::  HandleLike h =>-	S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString)-getRBuf = 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--setRBuf, setWBuf :: HandleLike h =>-	S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()-setRBuf = (modify .) . S.setBuf; setWBuf = (modify .) . S.setWBuf--getWSn, getRSn :: HandleLike h => S.PartnerId -> TlsM h g Word64-getWSn = gets . S.getWriteSN; getRSn = gets . S.getReadSN--sccWSn, sccRSn :: HandleLike h => S.PartnerId -> TlsM h g ()-sccWSn = modify . S.succWriteSN; sccRSn = modify . S.succReadSN--rstWSn, rstRSn :: HandleLike h => S.PartnerId -> TlsM h g ()-rstWSn = modify . S.resetWriteSN; rstRSn = modify . S.resetReadSN--getCipherSuite :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite-getCipherSuite = gets . S.getCipherSuite--setCipherSuite :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()-setCipherSuite = (modify .) . S.setCipherSuite--getNames :: HandleLike h => S.PartnerId -> TlsM h g [String]-getNames = gets . S.getNames--setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g ()-setNames = (modify .) . S.setNames--setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g ()-setKeys = (modify .) . S.setKeys--getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys-getKeys = gets . S.getKeys--getSettingsS :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS-getSettingsS = gets . S.getInitSet--getSettings :: HandleLike h => S.PartnerId -> TlsM h g S.Settings-getSettings = gets . S.getSettings--setSettingsS :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g ()-setSettingsS = (modify .) . S.setInitSet--setSettings :: HandleLike h => S.PartnerId -> S.Settings -> TlsM h g ()-setSettings = (modify .) . S.setSettings--getClFinished, getSvFinished ::-	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString-getClFinished = gets . S.getClientFinished-getSvFinished = gets . S.getServerFinished--setClFinished, setSvFinished ::-	HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()-setClFinished = (modify .) . S.setClientFinished-setSvFinished = (modify .) . S.setServerFinished--flushCipherSuite :: HandleLike h => RW -> S.PartnerId -> TlsM h g ()-flushCipherSuite rw = case rw of-	Read -> flushCipherSuiteRead-	Write -> flushCipherSuiteWrite--flushCipherSuiteRead, flushCipherSuiteWrite ::-	HandleLike h => S.PartnerId -> TlsM h g ()-flushCipherSuiteRead = modify . S.flushCipherSuiteRead-flushCipherSuiteWrite = modify . S.flushCipherSuiteWrite--withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a-withRandom p = p `liftM` gets S.randomGen >>=-	uncurry (flip (>>)) . (return *** modify . S.setRandomGen)--tGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString-tGet = ((lift . lift) .) . hlGet--tPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()-tPut = ((lift . lift) .) . hlPut--tClose :: HandleLike h => h -> TlsM h g ()-tClose = lift . lift . hlClose--tDebug :: HandleLike h =>-	h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()-tDebug = (((lift . lift) .) .) . hlDebug--thlError :: HandleLike h => h -> BS.ByteString -> TlsM h g a-thlError = ((lift . lift) .) . hlError--getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g SettingsC-getSettingsC i = do-	(css, crts, mcs) <- getSettings i-	case mcs of-		Just cs -> return (css, crts, cs)-		_ -> throwError "Network.PeyoTLS.Base.getSettingsC"--setSettingsC :: HandleLike h => S.PartnerId -> SettingsC -> TlsM h g ()-setSettingsC i (css, crts, cs) = setSettings i (css, crts, Just cs)--type SettingsC = (-	[S.CipherSuite],-	[(S.CertSecretKey, X509.CertificateChain)],-	X509.CertificateStore )--data RW = Read | Write deriving Show

@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}  module Network.PeyoTLS.Run ( H.debug,-	H.TlsM, H.run, H.TlsHandleBase(..),+	H.TlsM, H.run, H.HandleBase, 		adGet, adGetLine, adGetContent, H.adPut, H.adDebug, H.adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, 		chGet, ccsPut, hsPut, updateHash, flushAd,@@ -17,18 +17,16 @@ 	H.AlertLevel(..), H.AlertDesc(..), debugCipherSuite, throw ) where  import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first, second, (***))+import Control.Arrow ((***)) import Control.Monad (liftM)-import "monads-tf" Control.Monad.Trans (lift)-import "monads-tf" Control.Monad.State (-	StateT, evalStateT, execStateT, get, gets, modify )+import "monads-tf" Control.Monad.Reader (ReaderT, runReaderT, lift, ask)+import "monads-tf" Control.Monad.State (StateT, evalStateT, get, modify ) import "monads-tf" Control.Monad.Error (throwError) import Data.Word (Word8) 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 Data.ASN1.Types as ASN1 import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509@@ -36,9 +34,9 @@ import qualified Codec.Bytable.BigEndian as B import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Network.PeyoTLS.Handle as H ( debug,+import qualified Network.PeyoTLS.Run.Handle as H ( debug, 	TlsM, run, withRandom,-	TlsHandleBase(..), CipherSuite,+	HandleBase, CipherSuite, 		newHandle, chGet, ccsPut, hsPut, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose, 		flushAd, getBuf, setBuf,@@ -52,52 +50,51 @@ 		RW(..), flushCipherSuite, 	ValidateHandle(..), tValidate, 	CertSecretKey(..), isRsaKey, isEcdsaKey,-	Alert(..), AlertLevel(..), AlertDesc(..), debugCipherSuite )+	Alert(..), AlertLevel(..), AlertDesc(..), debugCipherSuite,+	splitLine )  modNm :: String modNm = "Network.PeyoTLS.Run" -type RenegoProc h g = H.TlsHandleBase h g -> H.TlsM h g ()+type RenegoProc h g = H.HandleBase h g -> H.TlsM h g ()  adGet :: (HandleLike h, CPRG g) =>-	RenegoProc h g -> H.TlsHandleBase h g -> Int -> H.TlsM h g BS.ByteString+	RenegoProc h g -> H.HandleBase h g -> Int -> H.TlsM h g BS.ByteString adGet rp t n = H.getBuf t >>= \b -> if BS.length b >= n 	then uncurry (>>) . (H.setBuf t *** return) $ BS.splitAt n b 	else BS.append b `liftM` H.adGet rp t (n - BS.length b)  adGetLine :: (HandleLike h, CPRG g) =>-	RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString-adGetLine rp t = H.getBuf t >>= \b -> if '\n' `BSC.elem` b || '\r' `BSC.elem` b-	then uncurry (>>) . (H.setBuf t *** return) $ case BSC.span (/= '\r') b of-		(_, "") -> second BS.tail $ BSC.span (/= '\n') b-		(l, ls) -> case BSC.uncons ls of-			Just ('\r', ls') -> case BSC.uncons ls' of-				Just ('\n', ls'') -> (l, ls'')-				_ -> (l, ls')-			_ -> (l, ls)-	else (b `BS.append`) `liftM` H.adGetLine rp t+	RenegoProc h g -> H.HandleBase h g -> H.TlsM h g BS.ByteString+adGetLine rp t = H.getBuf t >>= \b -> case H.splitLine b of+	Just (l, ls) -> H.setBuf t ls >> return l+	_ -> (b `BS.append`) `liftM` H.adGetLine rp t  adGetContent :: (HandleLike h, CPRG g) =>-	RenegoProc h g -> H.TlsHandleBase h g -> H.TlsM h g BS.ByteString+	RenegoProc h g -> H.HandleBase h g -> H.TlsM h g BS.ByteString adGetContent rp t = H.getBuf t >>= \b -> 	if BS.null b then H.adGetContent rp t else H.setBuf t "" >> return b -type HandshakeM h g = StateT (H.TlsHandleBase h g, SHA256.Ctx) (H.TlsM h g)+type HandshakeM h g =+	ReaderT (H.HandleBase h g) (StateT SHA256.Ctx (H.TlsM h g))  execHandshakeM ::-	HandleLike h => h -> HandshakeM h g () -> H.TlsM h g (H.TlsHandleBase h g)-execHandshakeM h =-	liftM fst . ((, SHA256.init) `liftM` H.newHandle h >>=) . execStateT+	HandleLike h => h -> HandshakeM h g () -> H.TlsM h g (H.HandleBase h g)+execHandshakeM h m = do+	t <- H.newHandle h+	m `runReaderT` t `evalStateT` SHA256.init+	return t+--	liftM fst . ((, SHA256.init) `liftM` H.newHandle h >>=) . execStateT  rerunHandshakeM ::-	HandleLike h => H.TlsHandleBase h g -> HandshakeM h g a -> H.TlsM h g a-rerunHandshakeM = flip evalStateT . (, SHA256.init)+	HandleLike h => H.HandleBase h g -> HandshakeM h g a -> H.TlsM h g a+rerunHandshakeM t m = m `runReaderT` t `evalStateT` SHA256.init  withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a-withRandom = lift . H.withRandom+withRandom = lift . lift . H.withRandom  chGet :: (HandleLike h, CPRG g) => HandshakeM h g (Either Word8 BS.ByteString)-chGet = gets fst >>= lift . flip H.chGet 1 >>= \ch -> case ch of+chGet = ask >>= lift . lift . flip H.chGet 1 >>= \ch -> case ch of 	Left w -> return $ Left w 	Right t -> Right `liftM` do 		len <- hsGet 3@@ -105,77 +102,79 @@ 		return $ BS.concat [t, len, body]  hsGet :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString-hsGet n = gets fst >>= lift . flip H.chGet n >>= \ch -> case ch of+hsGet n = ask >>= lift . lift . flip H.chGet n >>= \ch -> case ch of 	Right bs -> return bs-	_ -> throw H.ALFatal H.ADUnexMsg $ modNm ++ ".hsGet: not handshake"+	_ -> throw H.ALFtl H.ADUnexMsg $ modNm ++ ".hsGet: not handshake"  ccsPut :: (HandleLike h, CPRG g) => Word8 -> HandshakeM h g ()-ccsPut = (gets fst >>=) . (lift .) . flip H.ccsPut+ccsPut = (ask >>=) . ((lift . lift) .) . flip H.ccsPut  hsPut :: (HandleLike h, CPRG g) => BS.ByteString -> HandshakeM h g ()-hsPut = (gets fst >>=) . (lift .) . flip H.hsPut+hsPut = (ask >>=) . ((lift . lift) .) . flip H.hsPut  updateHash :: HandleLike h => BS.ByteString -> HandshakeM h g ()-updateHash = modify . second . flip SHA256.update+updateHash = modify . flip SHA256.update  flushAd :: (HandleLike h, CPRG g) => HandshakeM h g Bool-flushAd = gets fst >>= lift . H.flushAd >>= uncurry (>>) . (push *** return)-	where push bs = gets fst >>= lift . H.getBuf >>=-		(gets fst >>=) . (lift .) . flip H.setBuf . (`BS.append` bs)+flushAd = ask >>= lift . lift . H.flushAd >>= uncurry (>>) . (push *** return)+	where push bs = ask >>= lift . lift . H.getBuf >>=+		(ask >>=) . ((lift . lift) .) . flip H.setBuf . (`BS.append` bs)  getSettingsC :: HandleLike h => HandshakeM h g H.SettingsC-getSettingsC = gets fst >>= lift . H.getSettingsC+getSettingsC = ask >>= lift . lift . H.getSettingsC  setSettingsC :: HandleLike h => H.SettingsC -> HandshakeM h g ()-setSettingsC = (gets fst >>=) . (lift .) . flip H.setSettingsC+setSettingsC = (ask >>=) . ((lift . lift) .) . flip H.setSettingsC  getSettingsS :: HandleLike h => HandshakeM h g H.SettingsS-getSettingsS = gets fst >>= lift . H.getSettingsS+getSettingsS = ask >>= lift . lift . H.getSettingsS  setSettingsS :: HandleLike h => H.SettingsS -> HandshakeM h g ()-setSettingsS = (gets fst >>=) . (lift .) . flip H.setSettingsS+setSettingsS = (ask >>=) . ((lift . lift) .) . flip H.setSettingsS  getCipherSuite :: HandleLike h => HandshakeM h g H.CipherSuite-getCipherSuite = gets fst >>= lift . H.getCipherSuite+getCipherSuite = ask >>= lift . lift . H.getCipherSuite  setCipherSuite :: HandleLike h => H.CipherSuite -> HandshakeM h g ()-setCipherSuite = (gets fst >>=) . (lift .) . flip H.setCipherSuite+setCipherSuite = (ask >>=) . ((lift . lift) .) . flip H.setCipherSuite  getClFinished, getSvFinished :: HandleLike h => HandshakeM h g BS.ByteString-getClFinished = gets fst >>= lift . H.getClFinished-getSvFinished = gets fst >>= lift . H.getSvFinished+getClFinished = ask >>= lift . lift . H.getClFinished+getSvFinished = ask >>= lift . lift . H.getSvFinished  setClFinished, setSvFinished :: HandleLike h => BS.ByteString -> HandshakeM h g ()-setClFinished = (gets fst >>=) . (lift .) . flip H.setClFinished-setSvFinished = (gets fst >>=) . (lift .) . flip H.setSvFinished+setClFinished = (ask >>=) . ((lift . lift) .) . flip H.setClFinished+setSvFinished = (ask >>=) . ((lift . lift) .) . flip H.setSvFinished  flushCipherSuite :: (HandleLike h, CPRG g) => H.RW -> HandshakeM h g ()-flushCipherSuite = (gets fst >>=) . (lift .) . H.flushCipherSuite+flushCipherSuite = (ask >>=) . ((lift . lift) .) . H.flushCipherSuite  makeKeys :: HandleLike h => H.Side -> 	(BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g ()-makeKeys s (cr, sr) pms = gets fst >>= \t -> lift $+makeKeys s (cr, sr) pms = ask >>= \t -> lift . lift $ 	H.getCipherSuite t >>= H.makeKeys t s cr sr pms >>= H.setKeys t  handshakeHash :: HandleLike h => HandshakeM h g BS.ByteString-handshakeHash = SHA256.finalize `liftM` gets snd+handshakeHash = SHA256.finalize `liftM` get  finishedHash :: (HandleLike h, CPRG g) => H.Side -> HandshakeM h g BS.ByteString-finishedHash s = get >>= lift . uncurry (H.finishedHash s) . second SHA256.finalize+finishedHash s = do+	t <- ask+	h <- get+	lift . lift $ H.finishedHash s t (SHA256.finalize h)  validateAlert :: [X509.FailedReason] -> H.AlertDesc validateAlert vr-	| X509.UnknownCA `elem` vr = H.ADUnknownCa-	| X509.Expired `elem` vr = H.ADCertificateExpired-	| X509.InFuture `elem` vr = H.ADCertificateExpired-	| otherwise = H.ADCertificateUnknown+	| X509.UnknownCA `elem` vr = H.ADUnkCa+	| X509.Expired `elem` vr = H.ADCertEx+	| X509.InFuture `elem` vr = H.ADCertEx+	| otherwise = H.ADCertUnk  handshakeValidate :: H.ValidateHandle h => X509.CertificateStore -> 	X509.CertificateChain -> HandshakeM h g [X509.FailedReason]-handshakeValidate cs cc@(X509.CertificateChain (c : _)) = gets fst >>= \t -> do-	lift . H.setNames t . certNames $ X509.getCertificate c-	modify . first $ const t { H.names = certNames $ X509.getCertificate c }-	lift $ H.tValidate t cs cc+handshakeValidate cs cc@(X509.CertificateChain (c : _)) =  ask >>= \t -> do+	lift . lift . H.setNames t . certNames $ X509.getCertificate c+	lift . lift $ H.tValidate t cs cc handshakeValidate _ _ = error $ modNm ++ ".handshakeValidate: empty cert chain"  certNames :: X509.Certificate -> [String]@@ -188,7 +187,7 @@ 			. X509.extensionGet . X509.certExtensions  debugCipherSuite :: HandleLike h => String -> HandshakeM h g ()-debugCipherSuite = (gets fst >>=) . (lift .) . flip H.debugCipherSuite+debugCipherSuite = (ask >>=) . ((lift . lift) .) . flip H.debugCipherSuite  throw :: HandleLike h => H.AlertLevel -> H.AlertDesc -> String -> HandshakeM h g a throw = ((throwError .) .) . H.Alert

@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++module Network.PeyoTLS.Run.Crypto (+	makeKeys, decrypt, encrypt, sha1, sha256,+	Side(..), finishedHash ) where++import Prelude hiding (splitAt, take)++import Control.Arrow (first)+import Data.Bits (xor)+import Data.Word (Word16, Word64)+import "crypto-random" Crypto.Random (CPRG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Cipher.AES as AES++modNm :: String+modNm = "Network.PeyoTLS.Crypto"++type Hash = BS.ByteString -> BS.ByteString++sha1, sha256 :: (Hash, Int)+sha1 = (SHA1.hash, 20)+sha256 = (SHA256.hash, 32)++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] = sep kls ems in (ms, cwmk, swmk, cwk, swk)+	where+	sep [] _ = []+	sep (n : ns) bs+		| BSL.null bs = []+		| otherwise = let (x, bs') = splitAt n bs in x : sep 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++decrypt :: (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 ->+	BS.ByteString -> BS.ByteString -> Either String BS.ByteString+decrypt (hs, ml) k mk sn pre enc =+	if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n"+	where+	pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc+	up = BS.take (BS.length pln - fromIntegral (lst pln) - 1) pln+	(b, rm) = BS.splitAt (BS.length up - ml) up+	em = calcMac hs mk sn $ pre `BS.append` B.addLen w16 b+	lst "" = error $ modNm ++ ".decrypt"+	lst bs = BS.last bs++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++calcMac :: Hash -> BS.ByteString -> Word64 -> BS.ByteString -> BS.ByteString+calcMac hs mk sn m = hmac hs 64 mk $ B.encode sn `BS.append` m++data Side = Server | Client deriving (Show, Eq)++finishedHash :: Side -> BS.ByteString -> BS.ByteString -> BS.ByteString+finishedHash s hs ms = take 12 . prf ms . (`BS.append` hs) $ case s of+	Client -> "client finished"+	Server -> "server finished"++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

@@ -0,0 +1,288 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++module Network.PeyoTLS.Run.Handle ( debug,+	M.TlsM, M.run, M.withRandom,+	HandleBase, M.CipherSuite,+		newHandle, chGet, ccsPut, hsPut,+		adGet, adGetLine, splitLine, adGetContent, adPut, adDebug, adClose,+		flushAd, getBuf, setBuf,+		getCipherSuite, setCipherSuite,+		M.SettingsC, getSettingsC, setSettingsC,+		M.SettingsS, getSettingsS, setSettingsS,+		getClFinished, getSvFinished, setClFinished, setSvFinished,+		getNames, setNames, makeKeys, setKeys,+		M.Side(..), finishedHash,+		M.RW(..), flushCipherSuite,+	ValidateHandle(..), tValidate,+	M.CertSecretKey(..), M.isRsaKey, M.isEcdsaKey,+	M.Alert(..), M.AlertLevel(..), M.AlertDesc(..), debugCipherSuite ) where++import Control.Arrow (first, second)+import Control.Monad (when, unless, liftM, ap)+import "monads-tf" Control.Monad.State (lift, get, put)+import Data.Word (Word8, Word16)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B++import qualified Network.PeyoTLS.Run.Monad as M (+	TlsM, run, throw, withRandom,+		Alert(..), AlertLevel(..), AlertDesc(..),+		tGet, decrypt, tPut, encrypt, tClose, tDebug,+	PartnerId, newPartner, ContType(..),+		getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn,+		getClFinished, getSvFinished, setClFinished, setSvFinished,+		getNames, setNames,+	CipherSuite(..), CertSecretKey(..), isRsaKey, isEcdsaKey,+		SettingsC, getSettingsC, setSettingsC,+		SettingsS, getSettingsS, setSettingsS,+		RW(..), getCipherSuite, setCipherSuite, flushCipherSuite,+	Keys(..), makeKeys, getKeys, setKeys,+	Side(..), finishedHash )++modNm :: String+modNm = "Network.PeyoTLS.Handle"++vrsn :: BS.ByteString+vrsn = "\x03\x03"++data HandleBase h g = Handle { pid :: M.PartnerId, handle :: h } deriving Show++newHandle :: HandleLike h => h -> M.TlsM h g (HandleBase h g)+newHandle h = M.newPartner `liftM` get >>= \(i, s) ->+	put s >> return Handle { pid = i, handle = h }++chGet :: (HandleLike h, CPRG g) =>+	HandleBase h g -> Int -> M.TlsM h g (Either Word8 BS.ByteString)+chGet _ 0 = return $ Right ""+chGet h n = getType h >>= \ct -> case ct of+	M.CTCCSpec -> (Left . head . BS.unpack) `liftM`+		(const `liftM` tRead h 1 `ap` M.rstSn M.Read (pid h))+	M.CTHandshake -> Right `liftM` tRead h n+	M.CTAlert -> M.throw M.ALFtl M.ADUnk+		. ((modNm ++ ".chGet: ") ++) . show =<< tRead h 2+	_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".chGet: not handshake"++tRead :: (HandleLike h, CPRG g) => HandleBase h g -> Int -> M.TlsM h g BS.ByteString+tRead h n = do+	(ct, b) <- M.getRBuf $ pid h; let n' = n - BS.length b+	if n' <= 0+	then cut h n ct b+	else do	(ct', b') <- getCont h+		unless (ct' == ct) . M.throw M.ALFtl M.ADUnk $+			modNm ++ ".tRead: content type confliction\n"+		when (BS.null b') $ M.throw M.ALFtl M.ADUnk  $+			modNm ++ ".tRead: no data available\n"+		M.setRBuf (pid h) (ct', b')+		(b `BS.append`) `liftM` tRead h n'++cut :: HandleLike h => HandleBase h g ->+	Int -> M.ContType -> BS.ByteString -> M.TlsM h g BS.ByteString+cut h n ct b = (const r `liftM`) . M.setRBuf (pid h) $+	(if BS.null b' then M.CTNull else ct, b')+	where (r, b') = BS.splitAt n b++ccsPut :: (HandleLike h, CPRG g) => HandleBase h g -> Word8 -> M.TlsM h g ()+ccsPut t w =+	const `liftM` tWrite t M.CTCCSpec (BS.pack [w]) `ap` M.rstSn M.Write (pid t)++hsPut :: (HandleLike h, CPRG g) => HandleBase h g -> BS.ByteString -> M.TlsM h g ()+hsPut = flip tWrite M.CTHandshake++adGet :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) ->+	HandleBase h g -> Int -> M.TlsM h g BS.ByteString+adGet rp h n = getType h >>= \ct -> case ct of+	M.CTAppData -> tRead h n+	M.CTHandshake -> rp h >> adGet rp h n+	M.CTAlert -> tRead h 2 >>= \al -> case al of+		"\SOH\NUL" -> tWrite h M.CTAlert "\SOH\NUL" >>+			M.throw M.ALFtl M.ADUnk "EOF"+		_ -> M.throw M.ALFtl M.ADUnk $ "Alert: " ++ show al+	_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGet"++adGetLine :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) ->+	HandleBase h g -> M.TlsM h g BS.ByteString+adGetLine rp h = getType h >>= \ct -> case ct of+	M.CTAppData -> M.getRBuf (pid h) >>= \(bct, bbs) -> case splitLine bbs of+		Just (l, ls) -> do+			M.setRBuf (pid h) (if BS.null ls then M.CTNull else bct, ls)+			return l+		_ -> do	getCont h >>= M.setRBuf (pid h)+			(bbs `BS.append`) `liftM` adGetLine rp h+	M.CTHandshake -> rp h >> adGetLine rp h+	M.CTAlert -> tRead h 2 >>= \al -> case al of+		"\SOH\NUL" -> tWrite h M.CTAlert "\SOH\NUL" >>+			M.throw M.ALFtl M.ADUnk "EOF"+		_ -> M.throw M.ALFtl M.ADUnk $ "Alert: " ++ show al+	_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetLine"++splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)+splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of+	(True, _) -> case BSC.uncons rls of+		Just ('\n', rnls) -> Just (rl, rnls)+		_ -> Just (rl, rls)+	(_, True) -> Just (nl, nls)+	_ -> Nothing+	where+	(rl, Just ('\r', rls)) = second BSC.uncons $ BSC.span (/= '\r') bs+	(nl, Just ('\n', nls)) = second BSC.uncons $ BSC.span (/= '\n') bs++adGetContent :: (HandleLike h, CPRG g) => (HandleBase h g -> M.TlsM h g ()) ->+	HandleBase h g -> M.TlsM h g BS.ByteString+adGetContent rp h = getType h >>= \ct -> case ct of+	M.CTAppData -> bCont h+	M.CTHandshake -> rp h >> adGetContent rp h+	M.CTAlert -> tRead h 2 >>= \al -> case al of+		"\SOH\NUL" -> do+			tWrite h M.CTAlert "\SOH\NUL"+			M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetContent"+		_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetcontent"+	_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".adGetContent"++bCont :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g BS.ByteString+bCont h = snd `liftM` M.getRBuf (pid h) >>= \bp -> if BS.null bp+	then snd `liftM` getCont h+	else M.setRBuf (pid h) (M.CTNull, BS.empty) >> return bp++adPut :: (HandleLike h, CPRG g) => HandleBase h g -> BS.ByteString -> M.TlsM h g ()+adPut = flip tWrite M.CTAppData++adDebug :: HandleLike h =>+	HandleBase h g -> DebugLevel h -> BS.ByteString -> M.TlsM h g ()+adDebug = M.tDebug . handle++adClose :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g ()+adClose t = tWrite t M.CTAlert "\SOH\NUL" >> wFlush t >> M.tClose (handle t)++flushAd :: (HandleLike h, CPRG g) =>+	HandleBase h g -> M.TlsM h g (BS.ByteString, Bool)+flushAd t = getType t >>= \ct -> case ct of+	M.CTAppData -> bCont t >>= \ad -> first (ad `BS.append`) `liftM` flushAd t+	M.CTAlert -> tRead t 2 >>= \a -> case a of+		"\1\0" -> return ("", False)+		_ -> M.throw M.ALFtl M.ADUnk $ modNm ++ ".flushAd: " ++ show a+	_ -> return ("", True)++getBuf :: HandleLike h => HandleBase h g -> M.TlsM h g BS.ByteString+getBuf = M.getAdBuf . pid++setBuf :: HandleLike h => HandleBase h g -> BS.ByteString -> M.TlsM h g ()+setBuf = M.setAdBuf . pid++getType :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g M.ContType+getType h = M.getRBuf (pid h) >>= \(t, b) ->+	(\p -> case (t, b) of (M.CTNull, _) -> p; (_, "") -> p; _ -> return t) $ do+		c@(t', _) <- getCont h+		M.setRBuf (pid h) c >> return t'++getCont :: (HandleLike h, CPRG g) =>+	HandleBase h g -> M.TlsM h g (M.ContType, BS.ByteString)+getCont h = do+	wFlush h+	ct <- (either (M.throw M.ALFtl M.ADUnk) return . B.decode) =<< rd 1+	_v <- rd 2+	e <- rd =<< either (M.throw M.ALFtl M.ADUnk) return . B.decode =<< rd 2+	(ct ,) `liftM` M.decrypt (pid h) ct e+	where rd = M.tGet $ handle h++tWrite :: (HandleLike h, CPRG g) =>+	HandleBase h g -> M.ContType -> BS.ByteString -> M.TlsM h g ()+tWrite h ct p = do+	(bct, bp) <- M.getWBuf $ pid h+	case ct of+		M.CTCCSpec -> wFlush h >> M.setWBuf (pid h) (ct, p) >> wFlush h+		_	| bct /= M.CTNull && ct /= bct ->+				wFlush h >> M.setWBuf (pid h) (ct, p)+			| otherwise -> M.setWBuf (pid h) (ct, bp `BS.append` p)++wFlush :: (HandleLike h, CPRG g) => HandleBase h g -> M.TlsM h g ()+wFlush h = M.getWBuf (pid h) >>= \(bct, bp) -> do+	M.setWBuf (pid h) (M.CTNull, "")+	unless (bct == M.CTNull) $ M.encrypt (pid h) bct bp >>= \e ->+		M.tPut (handle h) $ BS.concat+			[B.encode bct, vrsn, B.addLen (undefined :: Word16) e]++getCipherSuite :: HandleLike h => HandleBase h g -> M.TlsM h g M.CipherSuite+getCipherSuite = M.getCipherSuite . pid++setCipherSuite :: HandleLike h => HandleBase h g -> M.CipherSuite -> M.TlsM h g ()+setCipherSuite = M.setCipherSuite . pid++getSettingsC :: HandleLike h => HandleBase h g -> M.TlsM h g M.SettingsC+getSettingsC = M.getSettingsC . pid++setSettingsC :: HandleLike h => HandleBase h g -> M.SettingsC -> M.TlsM h g ()+setSettingsC = M.setSettingsC . pid++getSettingsS :: HandleLike h => HandleBase h g -> M.TlsM h g M.SettingsS+getSettingsS = M.getSettingsS . pid++setSettingsS :: HandleLike h => HandleBase h g -> M.SettingsS -> M.TlsM h g ()+setSettingsS = M.setSettingsS . pid++getClFinished, getSvFinished ::+	HandleLike h => HandleBase h g -> M.TlsM h g BS.ByteString+getClFinished = M.getClFinished . pid+getSvFinished = M.getSvFinished . pid++setClFinished, setSvFinished ::+	HandleLike h => HandleBase h g -> BS.ByteString -> M.TlsM h g ()+setClFinished = M.setClFinished . pid+setSvFinished = M.setSvFinished . pid++getNames :: HandleLike h => HandleBase h g -> M.TlsM h g [String]+getNames = M.getNames . pid++setNames :: HandleLike h => HandleBase h g -> [String] -> M.TlsM h g ()+setNames = M.setNames . pid++makeKeys :: HandleLike h => HandleBase h g -> M.Side ->+	BS.ByteString -> BS.ByteString -> BS.ByteString -> M.CipherSuite ->+	M.TlsM h g M.Keys+makeKeys = flip M.makeKeys . pid++setKeys :: HandleLike h => HandleBase h g -> M.Keys -> M.TlsM h g ()+setKeys = M.setKeys . pid++flushCipherSuite :: HandleLike h => M.RW -> HandleBase h g -> M.TlsM h g ()+flushCipherSuite rw = M.flushCipherSuite rw . pid++finishedHash :: HandleLike h =>+	M.Side -> HandleBase h g -> BS.ByteString -> M.TlsM h g BS.ByteString+finishedHash s = M.finishedHash s . pid++debug :: (HandleLike h, Show a) =>+	HandleBase h g -> DebugLevel h -> a -> M.TlsM h g ()+debug t l x = lift . lift . hlDebug (handle t) l . BSC.pack . (++ "\n") $ show x++class HandleLike h => ValidateHandle h where+	validate :: h -> X509.CertificateStore -> X509.CertificateChain ->+		HandleMonad h [X509.FailedReason]++tValidate :: ValidateHandle h => HandleBase h g -> X509.CertificateStore ->+	X509.CertificateChain -> M.TlsM h g [X509.FailedReason]+tValidate = (((lift . lift) .) .) . validate . handle++instance ValidateHandle Handle where+	validate _ cs =+		X509.validate X509.HashSHA256 X509.defaultHooks ch cs ca ("", "")+		where+		ch = X509.defaultChecks { X509.checkFQHN = False }+		ca = X509.ValidationCache+			(\_ _ _ -> return X509.ValidationCacheUnknown)+			(\_ _ _ -> return ())++debugCipherSuite :: HandleLike h => HandleBase h g -> String -> M.TlsM h g ()+debugCipherSuite h a = do+	k <- M.getKeys $ pid h+	M.tDebug (handle h) "high" . BSC.pack+		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50+		. show $ M.kCchCSuite k+	where lenSpace n str = str ++ replicate (n - length str) ' '

@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++module Network.PeyoTLS.Run.Monad (+	TlsM, run, throw, withRandom,+		Alert(..), AlertLevel(..), AlertDesc(..),+		tGet, decrypt, tPut, encrypt, tClose, tDebug,+	S.PartnerId, S.newPartner, S.ContType(..),+		getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn,+		getClFinished, getSvFinished, setClFinished, setSvFinished,+		getNames, setNames,+	S.CipherSuite(..), S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey,+		S.SettingsC, getSettingsC, setSettingsC,+		S.SettingsS, getSettingsS, setSettingsS,+		S.RW(..), getCipherSuite, setCipherSuite, flushCipherSuite,+	S.Keys(..), makeKeys, getKeys, setKeys,+	C.Side(..), finishedHash ) where++import Control.Arrow ((***))+import Control.Monad (unless, liftM, ap)+import "monads-tf" Control.Monad.State (lift, StateT, evalStateT, gets, modify)+import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError)+import "monads-tf" Control.Monad.Error.Class (Error(..))+import Data.Word (Word8, Word64)+import Data.HandleLike (HandleLike(..))+import "crypto-random" Crypto.Random (CPRG)++import qualified Data.ByteString as BS+import qualified Codec.Bytable.BigEndian as B++import qualified Network.PeyoTLS.Run.State as S (+	TlsState, initState, PartnerId, newPartner,+		getGen, setGen, getNames, setNames,+		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn,+		getClFinished, getSvFinished, setClFinished, setSvFinished,+	ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,+	CipherSuite(..), BulkEnc(..), RW(..),+		getCipherSuite, setCipherSuite, flushCipherSuite,+	Keys(..), getKeys, setKeys,+	SettingsC, getSettingsC, setSettingsC,+	SettingsS, getSettingsS, setSettingsS,+	CertSecretKey(..), isRsaKey, isEcdsaKey )+import qualified Network.PeyoTLS.Run.Crypto as C (+	makeKeys, encrypt, decrypt, sha1, sha256, Side(..), finishedHash )++modNm :: String+modNm = "Network.PeyoTLS.Monad"++vrsn :: BS.ByteString+vrsn = "\3\3"++type TlsM h g = ErrorT Alert (StateT (S.TlsState h g) (HandleMonad h))++run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a+run m g = evalStateT (runErrorT m) (S.initState g) >>= \er -> case er of+		Right r -> return r+		Left a -> error $ show a++throw :: HandleLike h => AlertLevel -> AlertDesc -> String -> TlsM h g a+throw = ((throwError .) .) . Alert++data Alert = Alert AlertLevel AlertDesc String | NotDetected String deriving Show++data AlertLevel = ALWarning | ALFtl | ALRaw Word8 deriving Show++data AlertDesc+	= ADCloseNotify | ADUnexMsg   | ADBadRecMac  | ADRecOverflow | ADDecFail+	| ADHsFailure   | ADUnsCert   | ADCertEx     | ADCertUnk     | ADIllParam+	| ADUnkCa       | ADDecodeErr | ADDecryptErr | ADProtoVer    | ADInsSec+	| ADInternalErr | ADUnk       | ADRaw Word8+	deriving Show++instance Error Alert where strMsg = NotDetected++withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a+withRandom p = p `liftM` gets S.getGen >>=+	uncurry (flip (>>)) . (return *** modify . S.setGen)++tGet :: HandleLike h => h -> Int -> TlsM h g BS.ByteString+tGet h n = lift (lift $ hlGet h n) >>= \b -> do+	unless (BS.length b == n) . throw ALFtl ADUnk $+		modNm ++ ".tGet: read err " ++ show (BS.length b) ++ " " ++ show n+	return b++decrypt :: HandleLike h =>+	S.PartnerId -> S.ContType -> BS.ByteString -> TlsM h g BS.ByteString+decrypt i ct e = do+	ks <- getKeys i+	let	S.CipherSuite _ be = S.kRCSuite ks;+		wk = S.kRKey ks; mk = S.kRMKey ks+	sn <- udSn S.Read i+	case be of+		S.AES_128_CBC_SHA -> either (throw ALFtl ADUnk) return $+			C.decrypt C.sha1 wk mk sn (B.encode ct `BS.append` vrsn) e+		S.AES_128_CBC_SHA256 -> either (throw ALFtl ADUnk) return $+			C.decrypt C.sha256 wk mk sn (B.encode ct `BS.append` vrsn) e+		S.BE_NULL -> return e++tPut :: HandleLike h => h -> BS.ByteString -> TlsM h g ()+tPut = ((lift . lift) .) . hlPut++encrypt :: (HandleLike h, CPRG g) =>+	S.PartnerId -> S.ContType -> BS.ByteString -> TlsM h g BS.ByteString+encrypt i ct p = do+	ks <- getKeys i+	let	S.CipherSuite _ be = S.kWCSuite ks+		wk = S.kWKey ks; mk = S.kWMKey ks+	sn <- udSn S.Write i+	case be of+		S.AES_128_CBC_SHA -> withRandom $+			C.encrypt C.sha1 wk mk sn (B.encode ct `BS.append` vrsn) p+		S.AES_128_CBC_SHA256 -> withRandom $+			C.encrypt C.sha256 wk mk sn (B.encode ct `BS.append` vrsn) p+		S.BE_NULL -> return p++tClose :: HandleLike h => h -> TlsM h g ()+tClose = lift . lift . hlClose++tDebug :: HandleLike h => h -> DebugLevel h -> BS.ByteString -> TlsM h gen ()+tDebug = (((lift . lift) .) .) . hlDebug++getRBuf, getWBuf ::  HandleLike h =>+	S.PartnerId -> TlsM h g (S.ContType, BS.ByteString)+getRBuf = gets . S.getRBuf; getWBuf = gets . S.getWBuf++getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getAdBuf = gets . S.getAdBuf++setRBuf, setWBuf :: HandleLike h =>+	S.PartnerId -> (S.ContType, BS.ByteString) -> TlsM h g ()+setRBuf = (modify .) . S.setRBuf; setWBuf = (modify .) . S.setWBuf++setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setAdBuf = (modify .) . S.setAdBuf++udSn :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g Word64+udSn rw i = case rw of+	S.Read -> const `liftM` gets (S.getRSn i) `ap` modify (S.sccRSn i)+	S.Write -> const `liftM` gets (S.getWSn i) `ap` modify (S.sccWSn i)++rstSn :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g ()+rstSn rw = case rw of S.Read -> modify . S.rstRSn; S.Write -> modify . S.rstWSn++getClFinished, getSvFinished ::+	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getClFinished = gets . S.getClFinished+getSvFinished = gets . S.getSvFinished++setClFinished, setSvFinished ::+	HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setClFinished = (modify .) . S.setClFinished+setSvFinished = (modify .) . S.setSvFinished++getNames :: HandleLike h => S.PartnerId -> TlsM h g [String]+getNames = gets . S.getNames++setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g ()+setNames = (modify .) . S.setNames++getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsC+getSettingsC i = gets (S.getSettingsC i ) >>= maybe (throw ALFtl ADUnk "...") return++getSettingsS :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS+getSettingsS = gets . S.getSettingsS++setSettingsC :: HandleLike h => S.PartnerId -> S.SettingsC -> TlsM h g ()+setSettingsC = (modify .) . S.setSettingsC++setSettingsS :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g ()+setSettingsS = (modify .) . S.setSettingsS++getCipherSuite :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite+getCipherSuite = gets . S.getCipherSuite++setCipherSuite :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()+setCipherSuite = (modify .) . S.setCipherSuite++flushCipherSuite :: HandleLike h => S.RW -> S.PartnerId -> TlsM h g ()+flushCipherSuite = (modify .) . S.flushCipherSuite++makeKeys :: HandleLike h => C.Side -> S.PartnerId ->+	BS.ByteString -> BS.ByteString -> BS.ByteString -> S.CipherSuite ->+	TlsM h g S.Keys+makeKeys s t cr sr pms cs@(S.CipherSuite _ be) = do+	kl <- case be of+		S.AES_128_CBC_SHA -> return $ snd C.sha1+		S.AES_128_CBC_SHA256 -> return $ snd C.sha256+		_ -> throw ALFtl ADUnk $ modNm ++ ".makeKeys: bad bulk enc"+	let (ms, cwmk, swmk, cwk, swk) = C.makeKeys kl cr sr pms+	getKeys t >>= \k -> return $ case s of+		C.Client -> k {+			S.kCchCSuite = cs, S.kMSec = ms,+			S.kCchRMKey = swmk, S.kCchWMKey = cwmk,+			S.kCchRKey = swk, S.kCchWKey = cwk }+		C.Server -> k {+			S.kCchCSuite = cs, S.kMSec = ms,+			S.kCchRMKey = cwmk, S.kCchWMKey = swmk,+			S.kCchRKey = cwk, S.kCchWKey = swk }+makeKeys _ _ _ _ _ _ = throw ALFtl ADUnk $ modNm ++ ".makeKeys"++getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys+getKeys = gets . S.getKeys++setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g ()+setKeys = (modify .) . S.setKeys++finishedHash :: HandleLike h =>+	C.Side -> S.PartnerId -> BS.ByteString -> TlsM h g BS.ByteString+finishedHash s t hs = C.finishedHash s hs `liftM` S.kMSec `liftM` getKeys t

@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++module Network.PeyoTLS.Run.State (+	TlsState, initState, PartnerId, newPartner,+		getGen, setGen, getNames, setNames,+		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn,+		getClFinished, setClFinished, getSvFinished, setSvFinished,+	ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,+	CipherSuite(..), BulkEnc(..), RW(..),+		getCipherSuite, setCipherSuite, flushCipherSuite,+	Keys(..), getKeys, setKeys,+	SettingsC, getSettingsC, setSettingsC,+	SettingsS, getSettingsS, setSettingsS,+	CertSecretKey(..), isRsaKey, isEcdsaKey ) where++import Control.Applicative ((<$>))+import Control.Arrow (first)+import Data.Maybe (maybeToList)+import Data.List (find)+import Data.Word (Word8, Word64)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA++import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey)+import Network.PeyoTLS.CipherSuite (CipherSuite(..), KeyEx(KE_NULL), BulkEnc(..))++modNm :: String+modNm = "Network.PeyoTLS.State"++type Modify s = s -> s++data TlsState h g =+	TlsState { gen :: g, nextPid :: Int, states :: [(PartnerId, State1 g)] }++initState :: g -> TlsState h g+initState g = TlsState{ gen = g, nextPid = 0, states = [] }++getState :: PartnerId -> TlsState h g -> State1 g+getState i s = case lookup i $ states s of+	Just s1 -> s1+	_ -> error $ modNm ++ ".getState"++modState :: Modify (State1 g) -> PartnerId -> Modify (TlsState h g)+modState f i s = s { states = (i, f $ getState i s) : states s }++setState :: (a -> Modify (State1 g)) -> PartnerId -> a -> Modify (TlsState h g)+setState f i x s = modState (f x) i s++data State1 g = State1 {+	settings :: Settings,+	rnClFinished :: BS.ByteString, rnSvFinished :: BS.ByteString,+	sKeys :: Keys, readSN :: Word64, writeSN :: Word64,+	rBuffer :: (ContType, BS.ByteString), wBuffer :: (ContType, BS.ByteString),+	adBuffer :: BS.ByteString,+	sNames :: [String] }++type Settings = (+	[CipherSuite], [(CertSecretKey, X509.CertificateChain)],+	Maybe X509.CertificateStore )++data PartnerId = PartnerId Int deriving (Show, Eq)++newPartner :: TlsState h g -> (PartnerId, TlsState h g)+newPartner s@TlsState { nextPid = np, states = ss } = (+	PartnerId np ,+	s { nextPid = succ np, states = (PartnerId np, s1) : ss } )+	where+	s1 = State1 {+		settings = ([], [], Nothing),+		rnClFinished = "", rnSvFinished = "",+		sKeys = nullKeys, readSN = 0, writeSN = 0,+		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""), adBuffer = "",+		sNames = [] }++getGen :: TlsState h g -> g+getGen = gen++setGen :: g -> TlsState h g -> TlsState h g+setGen g st = st { gen = g }++getNames :: PartnerId -> TlsState h g -> [String]+getNames = (sNames .) . getState++setNames :: PartnerId -> [String] -> Modify (TlsState h g)+setNames = setState $ \n st -> st { sNames = n }++getRSn, getWSn :: PartnerId -> TlsState h g -> Word64+getRSn = (readSN .) . getState; getWSn = (writeSN .) . getState++rstRSn, rstWSn :: PartnerId -> Modify (TlsState h g)+rstRSn = modState $ \s -> s { readSN = 0 }+rstWSn = modState $ \s -> s { writeSN = 0 }++sccRSn, sccWSn :: PartnerId -> Modify (TlsState h g)+sccRSn = modState $ \s -> s { readSN = succ $ readSN s }+sccWSn = modState $ \s -> s { writeSN = succ $ writeSN s }++getClFinished, getSvFinished :: PartnerId -> TlsState h g -> BS.ByteString+getClFinished = (rnClFinished .) . getState+getSvFinished = (rnSvFinished .) . getState++setClFinished, setSvFinished :: PartnerId -> BS.ByteString -> Modify (TlsState h g)+setClFinished = setState $ \cf st -> st { rnClFinished = cf }+setSvFinished = setState $ \sf st -> st { rnSvFinished = sf }++data ContType = CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8+	deriving (Show, Eq)++instance B.Bytable ContType where+	encode CTNull = BS.pack [0]+	encode CTCCSpec = BS.pack [20]+	encode CTAlert = BS.pack [21]+	encode CTHandshake = BS.pack [22]+	encode CTAppData = BS.pack [23]+	encode (CTRaw ct) = BS.pack [ct]+	decode "\0" = Right CTNull+	decode "\20" = Right CTCCSpec+	decode "\21" = Right CTAlert+	decode "\22" = Right CTHandshake+	decode "\23" = Right CTAppData+	decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct+	decode _ = Left $ modNm ++ ": ContType.decode"++getRBuf, getWBuf :: PartnerId -> TlsState h g -> (ContType, BS.ByteString)+getRBuf = (rBuffer .) . getState; getWBuf = (wBuffer .) . getState++getAdBuf :: PartnerId -> TlsState h g -> BS.ByteString+getAdBuf = (adBuffer .) . getState++setRBuf, setWBuf :: PartnerId -> (ContType, BS.ByteString) -> Modify (TlsState h g)+setRBuf = setState $ \bs st -> st { rBuffer = bs }+setWBuf = setState $ \bs st -> st { wBuffer = bs }++setAdBuf :: PartnerId -> BS.ByteString -> Modify (TlsState h g)+setAdBuf = setState $ \bs st -> st { adBuffer = bs }++data RW = Read | Write deriving Show++getCipherSuite :: PartnerId -> TlsState h g -> CipherSuite+getCipherSuite = ((kCchCSuite . sKeys) .) . getState++setCipherSuite :: PartnerId -> CipherSuite -> Modify (TlsState h g)+setCipherSuite = setState $ \cs st -> st { sKeys = (sKeys st) { kCchCSuite = cs } }++flushCipherSuite :: RW -> PartnerId -> Modify (TlsState h g)+flushCipherSuite Read = flushCipherSuiteRead+flushCipherSuite Write = flushCipherSuiteWrite++flushCipherSuiteRead :: PartnerId -> Modify (TlsState h g)+flushCipherSuiteRead = modState $ \st -> st { sKeys = (sKeys st) {+	kRCSuite = kCchCSuite (sKeys st), kRMKey = kCchRMKey (sKeys st),+	kRKey = kCchRKey (sKeys st) } }++flushCipherSuiteWrite :: PartnerId -> Modify (TlsState h g)+flushCipherSuiteWrite = modState $ \st -> st { sKeys = (sKeys st) {+	kWCSuite = kCchCSuite (sKeys st), kWMKey = kCchWMKey (sKeys st),+	kWKey = kCchWKey (sKeys st) } }++data Keys = Keys {+	kMSec :: BS.ByteString,+	kRCSuite :: CipherSuite, kWCSuite :: CipherSuite,+	kRMKey :: BS.ByteString, kWMKey :: BS.ByteString,+	kRKey :: BS.ByteString, kWKey :: BS.ByteString,+	kCchCSuite :: CipherSuite,+	kCchRMKey :: BS.ByteString, kCchWMKey :: BS.ByteString,+	kCchRKey :: BS.ByteString, kCchWKey :: BS.ByteString }+	deriving (Show, Eq)++nullKeys :: Keys+nullKeys = Keys {+	kMSec = "",+	kRCSuite = CipherSuite KE_NULL BE_NULL,+	kWCSuite = CipherSuite KE_NULL BE_NULL,+	kRMKey = "", kWMKey = "", kRKey = "", kWKey = "",+	kCchCSuite = CipherSuite KE_NULL BE_NULL,+	kCchRMKey = "", kCchWMKey = "",+	kCchRKey = "", kCchWKey = "" }++getKeys :: PartnerId -> TlsState h g -> Keys+getKeys = (sKeys .) . getState++setKeys :: PartnerId -> Keys -> Modify (TlsState h g)+setKeys = setState $ \k st -> st { sKeys = k }++type SettingsC = (+	[CipherSuite], [(CertSecretKey, X509.CertificateChain)],+	X509.CertificateStore )++getSettingsC :: PartnerId -> TlsState h g -> Maybe SettingsC+getSettingsC i s = case settings $ getState i s of+	(css, crts, Just cs) -> Just (css, crts, cs)+	_ -> Nothing++setSettingsC :: PartnerId -> SettingsC -> Modify (TlsState h g)+setSettingsC =+	setState $ \(css, crts, cs) st -> st { settings = (css, crts, Just cs) }++type SettingsS = (+	[CipherSuite],+	Maybe (RSA.PrivateKey, X509.CertificateChain),+	Maybe (ECDSA.PrivateKey, X509.CertificateChain),+	Maybe X509.CertificateStore )++getSettingsS :: PartnerId -> TlsState h g -> SettingsS+getSettingsS = ((toS . settings) .) . getState+	where toS (cs, crts, mcs) = (cs,+		first rsaKey <$> find (isRsaKey . fst) crts,+		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)++setSettingsS :: PartnerId -> SettingsS -> Modify (TlsState h g)+setSettingsS = setState $ \is st -> st { settings = fromS is }+	where fromS (cs, rcrt, ecrt, mcs) = (cs,+		maybeToList (first RsaKey <$> rcrt) +++		maybeToList (first EcdsaKey <$> ecrt), mcs)

@@ -12,7 +12,7 @@  module Network.PeyoTLS.Server ( 	-- * Basic-	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, names, getNames,+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, getNames, 	-- * Renegotiation 	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, 	-- * Cipher Suite@@ -42,7 +42,7 @@ import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Network.PeyoTLS.Base as BASE (names, getNames)+import qualified Network.PeyoTLS.Base as BASE (getNames) import Network.PeyoTLS.Base ( debug, 	PeyotlsM, TlsM, run, 		SettingsS, getSettingsS, setSettingsS,@@ -51,27 +51,27 @@ 		withRandom, flushAd, 		AlertLevel(..), AlertDesc(..), throw, debugCipherSuite, 	ValidateHandle(..), handshakeValidate, validateAlert,-	TlsHandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,-		readHandshake, writeHandshake, ChangeCipherSpec(..),+	HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,+		readHandshake, writeHandshake, CCSpec(..), 	Handshake(HHelloReq),-	ClientHello(..), ServerHello(..), SessionId(..), Extension(..),-		isRenegoInfo, emptyRenegoInfo,+	ClHello(..), SvHello(..), SssnId(..), Extension(..),+		isRnInfo, emptyRnInfo, 		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..), HashAlg(..), SignAlg(..),+		CmpMtd(..), HashAlg(..), SignAlg(..), 		getCipherSuite, setCipherSuite, 		checkClRenego, makeSvRenego,-	ServerKeyEx(..), SvSignSecretKey(..),+	SvKeyEx(..), SvSignSecretKey(..), 	certReq, ClCertType(..),-	ServerHelloDone(..),-	ClientKeyEx(..), Epms(..), makeKeys,-	DigitallySigned(..), ClSignPublicKey(..), handshakeHash,+	SHDone(..),+	ClKeyEx(..), Epms(..), makeKeys,+	DigitSigned(..), ClSignPublicKey(..), handshakeHash, 	RW(..), flushCipherSuite, 	Side(..), finishedHash, 	DhParam(..), ecdsaPubKey )  type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandleBase h g } deriving Show+newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show  instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where 	type HandleMonad (TlsHandle h g) = TlsM h g@@ -91,11 +91,6 @@ moduleName :: String moduleName = "Network.PeyoTLS.Server" -{-# DEPRECATED names "Use getNames instead" #-}--names :: TlsHandle h g -> [String]-names = BASE.names . tlsHandleS- getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleS @@ -144,7 +139,7 @@ 	debug "low" ("after flushAd" :: String) 	when ne (handshake =<< getSettingsS) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandleBase h g -> TlsM h g ()+rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS  handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g ()@@ -154,26 +149,25 @@ 	ha <- case be of 		AES_128_CBC_SHA -> return Sha1 		AES_128_CBC_SHA256 -> return Sha256-		_ -> throw ALFatal ADInternalError $+		_ -> throw ALFtl ADInternalErr $ 			pre ++ "not implemented bulk encryption type" 	mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of 		(RSA, Just rsk, _) -> rsaKeyExchange rsk cv 		(DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk 		(ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk 		(ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk-		_ -> \_ _ -> throw ALFatal ADInternalError $+		_ -> \_ _ -> throw ALFtl ADInternalErr $ 			pre ++ "no implemented key exchange type or " ++ 				"no applicable certificate files" 	flip (maybe $ return ()) mpk $ \pk -> case pk of 		X509.PubKeyRSA rpk -> certVerify rpk 		X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy-		_ -> throw ALFatal ADUnsupportedCertificate $-			pre ++ "not implement: " ++ show pk-	ChangeCipherSpec <- readHandshake+		_ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk+	CCSpec <- readHandshake 	flushCipherSuite Read 	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok .-		throw ALFatal ADDecryptError $ pre ++ "wrong finished hash"-	writeHandshake ChangeCipherSpec+		throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash"+	writeHandshake CCSpec 	flushCipherSuite Write 	writeHandshake =<< finishedHash Server 	where pre = moduleName ++ ".handshake: "@@ -204,29 +198,28 @@ clientHello :: (HandleLike h, CPRG g) => [CipherSuite] -> 	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do-	ClientHello cv cr _sid cscl cms me <- readHandshake-	checkRenegoInfo cscl me-	unless (cv >= version) . throw ALFatal ADProtocolVersion $+	ClHello cv cr _sid cscl cms me <- readHandshake+	checkRnInfo cscl me+	unless (cv >= version) . throw ALFtl ADProtoVer $ 		pre ++ "only implement TLS 1.2"-	unless (CompMethodNull `elem` cms) . throw ALFatal ADDecodeError $+	unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $ 		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)-		_ -> throw ALFatal ADHsFailure $+		_ -> throw ALFtl ADHsFailure $ 			pre ++ "no acceptable set of security parameters: \n\t" ++ 			"cscl: " ++ show cscl ++ "\n\t" ++ 			"cssv: " ++ show cssv ++ "\n" 	return (ke, be, cr, cv) 	where pre = moduleName ++ ".clientHello: " -checkRenegoInfo ::+checkRnInfo :: 	HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()-checkRenegoInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw-	ALFatal ADInsufficientSecurity $-	moduleName ++ ".checkRenego: require secure renegotiation"+checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw+	ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation" 	where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of-		(True, _) -> Just emptyRenegoInfo-		(_, Just e) -> find isRenegoInfo e+		(True, _) -> Just emptyRnInfo+		(_, Just e) -> find isRnInfo e 		(_, _) -> Nothing  serverHello :: (HandleLike h, CPRG g) =>@@ -236,16 +229,16 @@ 	cs <- getCipherSuite 	ke <- case cs of 		CipherSuite k _ -> return k-		_ -> throw ALFatal ADInternalError $+		_ -> throw ALFtl ADInternalErr $ 			moduleName ++ ".serverHello: never occur" 	sr <- withRandom $ cprgGenerate 32 	writeHandshake-		. ServerHello version sr (SessionId "") cs CompMethodNull+		. SvHello version sr (SssnId "") cs CmpMtdNull 		. Just . (: []) =<< makeSvRenego 	writeHandshake =<< case (ke, rcc, ecc) of 		(ECDHE_ECDSA, _, Just c) -> return c 		(_, Just c, _) -> return c-		_ -> throw ALFatal ADInternalError $+		_ -> throw ALFtl ADInternalErr $ 			moduleName ++ ".serverHello: cert files not match" 	return sr @@ -259,9 +252,9 @@ 	where mkpms epms = do 		pms <- either (E.throwError . strMsg . show) return =<< 			withRandom (\g -> RSA.decryptSafer g sk epms)-		unless (BS.length pms == 48) $ throw ALFatal ADHsFailure ""+		unless (BS.length pms == 48) $ throw ALFtl ADHsFailure "" 		let [pvj, pvn] = BS.unpack $ BS.take 2 pms-		unless (pvj == vj && pvn == vn) $ throw ALFatal ADHsFailure ""+		unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure "" 		return pms  dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk,@@ -273,12 +266,12 @@ 	bl <- withRandom $ generateBlinder sk 	let pv = B.encode $ calculatePublic dp sv 	writeHandshake-		. ServerKeyEx (B.encode dp) pv ha (sssAlgorithm sk)+		. SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk) 		. ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv] 	const `liftM` reqAndCert mcs `ap` do-		ClientKeyEx cke <- readHandshake+		ClKeyEx cke <- readHandshake 		makeKeys Server rs . calculateShared dp sv =<<-			either (throw ALFatal ADInternalError .+			either (throw ALFtl ADInternalErr . 					(moduleName ++) . (".dhKeyExchange: " ++)) 				return (B.decode cke) @@ -291,7 +284,7 @@ 	flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do 		cc@(X509.CertificateChain (c : _)) <- readHandshake 		vr <- handshakeValidate cs cc-		unless (null vr) . throw ALFatal (validateAlert vr) $+		unless (null vr) . throw ALFtl (validateAlert vr) $ 			moduleName ++ ".reqAndCert: " ++ show vr 		return . X509.certPubKey $ X509.getCertificate c @@ -299,10 +292,10 @@ certVerify pk = do 	debugCipherSuite . show $ cspAlgorithm pk 	hs0 <- handshakeHash-	DigitallySigned a s <- readHandshake+	DigitSigned a s <- readHandshake 	case a of 		(Sha256, sa) | sa == cspAlgorithm pk -> return ()-		_ -> throw ALFatal ADDecodeError $+		_ -> throw ALFtl ADDecodeErr $ 			moduleName ++ ".certVerify: not implement: " ++ show a-	unless (csVerify pk s hs0) . throw ALFatal ADDecryptError $+	unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $ 		moduleName ++ ".certVerify: client auth failed "

@@ -1,275 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}--module Network.PeyoTLS.State (-	HandshakeState, initState, PartnerId, newPartnerId, Keys(..), nullKeys,-	ContentType(..), Alert(..), AlertLevel(..), AlertDesc(..),-	CipherSuite(..), KeyEx(..), BulkEnc(..),-	randomGen, setRandomGen,-	getBuf, setBuf, getWBuf, setWBuf,-	getAdBuf, setAdBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN,-	getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite,-	getKeys, setKeys,-	getSettings, setSettings,-	getInitSet, setInitSet,-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,--	SettingsS, Settings,-	CertSecretKey(..), isRsaKey, isEcdsaKey,--	getNames, setNames,-) where--import Control.Applicative ((<$>))-import Control.Arrow (first)-import "monads-tf" Control.Monad.Error.Class (Error(strMsg))-import Data.Maybe (fromJust, maybeToList)-import Data.List (find)-import Data.Word (Word8, Word64)-import Data.String (IsString(..))--import qualified Data.ByteString as BS-import qualified Codec.Bytable.BigEndian as B--import Network.PeyoTLS.CertSecretKey (CertSecretKey(..), isRsaKey, isEcdsaKey)-import qualified Data.X509 as X509-import qualified Data.X509.CertificateStore as X509--import Network.PeyoTLS.CipherSuite (-	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)] }--initState :: g -> HandshakeState h g-initState g = HandshakeState{ randomGen = g, nextPartnerId = 0, states = [] }--data PartnerId = PartnerId Int deriving (Show, Eq)--newPartnerId :: HandshakeState h g -> (PartnerId, HandshakeState h g)-newPartnerId s = (PartnerId i ,) s{-	nextPartnerId = succ i,-	states = (PartnerId i, so) : sos }-	where-	i = nextPartnerId s-	so = StateOne {-		sKeys = nullKeys,-		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""),-		radBuffer = "",-		readSN = 0, writeSN = 0,-		rnClientFinished = "", rnServerFinished = "",-		initialSettings = ([], [], Nothing),-		sNames = []-		}-	sos = states s--type SettingsS = (-	[CipherSuite],-	Maybe (RSA.PrivateKey, X509.CertificateChain),-	Maybe (ECDSA.PrivateKey, X509.CertificateChain),-	Maybe X509.CertificateStore )--type Settings = (-	[CipherSuite],-	[(CertSecretKey, X509.CertificateChain)],-	Maybe X509.CertificateStore )--convertSettings :: Settings -> SettingsS-convertSettings (cs, crts, mcs) = (cs,-	first rsaKey <$> find (isRsaKey . fst) crts,-	first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)--revertSettings :: SettingsS -> Settings-revertSettings (cs, rcrt, ecrt, mcs) = (cs,-	maybeToList (first RsaKey <$> rcrt) ++-	maybeToList (first EcdsaKey <$> ecrt), mcs)--data StateOne g = StateOne {-	sKeys :: Keys,-	rBuffer :: (ContentType, BS.ByteString),-	wBuffer :: (ContentType, BS.ByteString),-	radBuffer :: BS.ByteString,-	readSN :: Word64,-	writeSN :: Word64,-	rnClientFinished :: BS.ByteString,-	rnServerFinished :: BS.ByteString,-	initialSettings :: Settings,-	sNames :: [String]-	}--getState :: PartnerId -> HandshakeState h g -> StateOne g-getState i = fromJust' "getState" . lookup i . states--setState :: PartnerId -> StateOne g -> Modify (HandshakeState h g)-setState i so s = s { states = (i, so) : states s }--modifyState :: PartnerId -> Modify (StateOne g) -> Modify (HandshakeState h g)-modifyState i f s = setState i (f $ getState i s) s--data Keys = Keys {-	kCachedCS :: CipherSuite,-	kReadCS :: CipherSuite, kWriteCS :: CipherSuite,-	kMasterSecret :: BS.ByteString,-	kCachedReadMacKey :: BS.ByteString,-	kCachedWriteMacKey :: BS.ByteString,-	kCachedReadKey :: BS.ByteString,-	kCachedWriteKey :: BS.ByteString,-	kReadMacKey :: BS.ByteString, kWriteMacKey :: BS.ByteString,-	kReadKey :: BS.ByteString, kWriteKey :: BS.ByteString }-	deriving (Show, Eq)--nullKeys :: Keys-nullKeys = Keys {-	kCachedCS = CipherSuite KE_NULL BE_NULL,-	kReadCS = CipherSuite KE_NULL BE_NULL,-	kWriteCS = CipherSuite KE_NULL BE_NULL,-	kMasterSecret = "",-	kCachedReadMacKey = "", kCachedWriteMacKey = "",-	kCachedReadKey = "", kCachedWriteKey = "",-	kReadMacKey = "", kWriteMacKey = "", kReadKey = "", kWriteKey = "" }--data ContentType-	= CTCCSpec | CTAlert | CTHandshake | CTAppData | CTNull | CTRaw Word8-	deriving (Show, Eq)--instance B.Bytable ContentType where-	encode CTNull = BS.pack [0]-	encode CTCCSpec = BS.pack [20]-	encode CTAlert = BS.pack [21]-	encode CTHandshake = BS.pack [22]-	encode CTAppData = BS.pack [23]-	encode (CTRaw ct) = BS.pack [ct]-	decode "\0" = Right CTNull-	decode "\20" = Right CTCCSpec-	decode "\21" = Right CTAlert-	decode "\22" = Right CTHandshake-	decode "\23" = Right CTAppData-	decode bs | [ct] <- BS.unpack bs = Right $ CTRaw ct-	decode _ = Left "State.decodeCT"--data Alert = Alert AlertLevel AlertDesc String | NotDetected String-	deriving Show--data AlertLevel = ALWarning | ALFatal | ALRaw Word8 deriving Show--data AlertDesc-	= ADCloseNotify            | ADUnexMsg              | ADBadRecordMac-	| ADRecordOverflow         | ADDecompressionFailure | ADHsFailure-	| ADUnsupportedCertificate | ADCertificateExpired   | ADCertificateUnknown-	| ADIllegalParameter       | ADUnknownCa            | ADDecodeError-	| ADDecryptError           | ADProtocolVersion      | ADInsufficientSecurity-	| ADInternalError          | ADUnclasified-	| ADRaw Word8-	deriving Show--instance Error Alert where-	strMsg = NotDetected--instance IsString Alert where-	fromString = NotDetected--setRandomGen :: g -> HandshakeState h g -> HandshakeState h g-setRandomGen rg st = st { randomGen = rg }--getBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString)-getBuf i = rBuffer . fromJust' "getBuf" . lookup i . states--setBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g)-setBuf i = modifyState i . \bs st -> st { rBuffer = bs }--getAdBuf :: PartnerId -> HandshakeState h g -> BS.ByteString-getAdBuf i = radBuffer . fromJust' "getAdBuf" . lookup i . states--setAdBuf :: PartnerId -> BS.ByteString -> Modify (HandshakeState h g)-setAdBuf i = modifyState i . \bs st -> st { radBuffer = bs }--getCipherSuite :: PartnerId -> HandshakeState h g -> CipherSuite-getCipherSuite i =-	kCachedCS . sKeys . fromJust' "getCipherSuite" . lookup i . states--setCipherSuite :: PartnerId -> CipherSuite -> Modify (HandshakeState h g)-setCipherSuite i = modifyState i . \cs st ->-	st { sKeys = (sKeys st) { kCachedCS = cs } }--getNames :: PartnerId -> HandshakeState h g -> [String]-getNames i = sNames . fromJust' "getNames" . lookup i . states--setNames :: PartnerId -> [String] -> Modify (HandshakeState h g)-setNames i = modifyState i . \n st -> st { sNames = n }--getKeys :: PartnerId -> HandshakeState h g -> Keys-getKeys i = sKeys . fromJust' "getKeys" . lookup i . states--setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g)-setKeys i = modifyState i . \k st -> st { sKeys = k }--getSettings :: PartnerId -> HandshakeState h g -> Settings-getSettings i = initialSettings . fromJust' "getSettings" . lookup i . states--getInitSet :: PartnerId -> HandshakeState h g -> SettingsS-getInitSet i = convertSettings .-	initialSettings . fromJust' "getInitSet" . lookup i . states--setSettings :: PartnerId -> Settings -> Modify (HandshakeState h g)-setSettings i = modifyState i . \is st -> st { initialSettings = is }--setInitSet :: PartnerId -> SettingsS -> Modify (HandshakeState h g)-setInitSet i = modifyState i . \is st -> st-	{ initialSettings = revertSettings is }--getClientFinished, getServerFinished ::-	PartnerId -> HandshakeState h g -> BS.ByteString-getClientFinished i =-	rnClientFinished . fromJust' "getClientFinished" . lookup i . states-getServerFinished i =-	rnServerFinished . fromJust' "getClientFinished" . lookup i . states--setClientFinished, setServerFinished ::-	PartnerId -> BS.ByteString -> Modify (HandshakeState h g)-setClientFinished i = modifyState i . \cf st -> st { rnClientFinished = cf }-setServerFinished i = modifyState i . \sf st -> st { rnServerFinished = sf }--flushCipherSuiteRead :: PartnerId -> Modify (HandshakeState h g)-flushCipherSuiteRead i = modifyState i $ \st ->-	st { sKeys = (sKeys st) {-		kReadCS = kCachedCS (sKeys st),-		kReadMacKey = kCachedReadMacKey (sKeys st),-		kReadKey = kCachedReadKey (sKeys st)-		} }--flushCipherSuiteWrite :: PartnerId -> Modify (HandshakeState h g)-flushCipherSuiteWrite i = modifyState i $ \st ->-	st { sKeys = (sKeys st) {-		kWriteCS = kCachedCS (sKeys st),-		kWriteMacKey = kCachedWriteMacKey (sKeys st),-		kWriteKey = kCachedWriteKey (sKeys st)-		} }--getWBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString)-getWBuf i = wBuffer . fromJust' "getWriteBuffer" . lookup i . states--setWBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g)-setWBuf i = modifyState i . \bs st -> st{ wBuffer = bs }--getReadSN, getWriteSN :: PartnerId -> HandshakeState h g -> Word64-getReadSN i = readSN . fromJust . lookup i . states-getWriteSN i = writeSN . fromJust . lookup i . states--succReadSN, succWriteSN :: PartnerId -> Modify (HandshakeState h g)-succReadSN i = modifyState i $ \s -> s{ readSN = succ $ readSN s }-succWriteSN i = modifyState i $ \s -> s{ writeSN = succ $ writeSN s }--resetReadSN, resetWriteSN :: PartnerId -> Modify (HandshakeState h g)-resetReadSN i = modifyState i $ \s -> s{ readSN = 0 }-resetWriteSN i = modifyState i $ \s -> s{ writeSN = 0 }--type Modify s = s -> s--fromJust' :: String -> Maybe a -> a-fromJust' _ (Just x) = x-fromJust' msg _ = error msg

@@ -1,266 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.PeyoTLS.Types (-	Handshake(..), HandshakeItem(..),-	ClientHello(..), ServerHello(..), SessionId(..),-		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CompMethod(..), Extension(..), isRenegoInfo, emptyRenegoInfo,-	ServerKeyEx(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	CertReq(..), certReq, ClCertType(..),-		SignAlg(..), HashAlg(..),-	ServerHelloDone(..), ClientKeyEx(..), Epms(..),-	DigitallySigned(..), Finished(..),-	ChangeCipherSpec(..), ) 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 (-	CertReq(..), certReq, ClCertType(..),-	ClientKeyEx(..), DigitallySigned(..) )--data Handshake-	= HHelloReq-	| HClientHello ClientHello           | HServerHello ServerHello-	| HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString-	| HCertificateReq CertReq            | HServerHelloDone-	| HCertVerify DigitallySigned        | HClientKeyEx ClientKeyEx-	| HFinished BS.ByteString            | HRaw Type BS.ByteString-	| HCCSpec-	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-encodeH HCCSpec = B.encode ChangeCipherSpec--class HandshakeItem hi where-	fromHandshake :: Handshake -> Maybe hi; toHandshake :: hi -> Handshake--instance HandshakeItem Handshake where-	fromHandshake = Just; toHandshake = id--instance HandshakeItem ChangeCipherSpec where-	fromHandshake HCCSpec = Just ChangeCipherSpec-	fromHandshake _ = Nothing-	toHandshake ChangeCipherSpec = HCCSpec-	toHandshake (ChangeCipherSpecRaw _) = error "bad"--instance (HandshakeItem l, HandshakeItem r) => HandshakeItem (Either l r) where-	fromHandshake hs = let-		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 ServerKeyEx = 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 ServerKeyEx 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 ServerKeyEx 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 CertReq where-	fromHandshake (HCertificateReq cr) = Just cr-	fromHandshake _ = Nothing-	toHandshake = HCertificateReq--instance HandshakeItem ServerHelloDone where-	fromHandshake HServerHelloDone = Just SHDone-	fromHandshake _ = Nothing-	toHandshake _ = HServerHelloDone--instance HandshakeItem DigitallySigned where-	fromHandshake (HCertVerify ds) = Just ds-	fromHandshake _ = Nothing-	toHandshake = HCertVerify--instance HandshakeItem ClientKeyEx 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 :: ClientKeyEx -> Maybe Epms-ckeToEpms (ClientKeyEx cke) = case B.runBytableM (B.take =<< B.take 2) cke of-	Right (e, "") -> Just $ Epms e-	_ -> Nothing--epmsToCke :: Epms -> ClientKeyEx-epmsToCke (Epms epms) = ClientKeyEx $ 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 = SHDone 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]--data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show--instance B.Bytable ChangeCipherSpec where-	decode bs = case BS.unpack bs of-		[1] -> Right ChangeCipherSpec-		[w] -> Right $ ChangeCipherSpecRaw w-		_ -> Left "HandshakeBase: ChangeCipherSpec.decode"-	encode ChangeCipherSpec = BS.pack [1]-	encode (ChangeCipherSpecRaw w) = BS.pack [w]--isRenegoInfo :: Extension -> Bool-isRenegoInfo (ERenegoInfo _) = True-isRenegoInfo _ = False--emptyRenegoInfo :: Extension-emptyRenegoInfo = ERenegoInfo ""