peyotls 0.0.0.19 → 0.0.0.20

raw patch · 12 files changed

+862/−323 lines, 12 filesdep +randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

API changes (from Hackage documentation)

Files

• peyotls.cabal +35/−13
• src/Network/PeyoTLS/Client.hs +126/−26
• src/Network/PeyoTLS/HandshakeBase.hs +59/−32
• src/Network/PeyoTLS/HandshakeMonad.hs +44/−30
• src/Network/PeyoTLS/HandshakeType.hs +16/−6
• src/Network/PeyoTLS/Server.hs +141/−192
• src/Network/PeyoTLS/State.hs +9/−0
• src/Network/PeyoTLS/TlsHandle.hs +95/−23
• src/Network/PeyoTLS/TlsMonad.hs +10/−1
• test/testCIRenego.hs +108/−0
• test/testDebug.hs +111/−0
• test/testReneg.hs +108/−0

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.19+version:	0.0.0.20 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -14,7 +14,7 @@ category:	Network synopsis:	Pretty Easy YOshikuni-made TLS library description:-    Currently implemente the TLS1.2 protocol only,+    Currently implement the TLS1.2 protocol only,     and support the following cipher suites.     .     * TLS_RSA_WITH_AES_128_CBC_SHA@@ -39,20 +39,12 @@     .     * ECDSA (SHA1 or SHA256 depending on the agreed cipher suite)     .-    And support secure renegotiation partially-    .-    * server can recieve client-initiated renegotiation-    .-    * can not send renegotiation from my client-    .-    * no server-initiated renegotiation+    And support secure renegotiation (RFC 5746)     .-    Currently not implemente the following features.+    Currently not implement the following features.     .     * session resumption (RFC 5077)     .-    * renegotiation (RFC 5746): partially-    .     Server sample     .     * file: examples/simpleServer.hs@@ -281,7 +273,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.19+    tag:	peyotls-0.0.0.20  library     hs-source-dirs:	src@@ -317,4 +309,34 @@     build-depends: peyotls, handle-like == 0.1.*,         base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,         x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*+    ghc-options: -Wall++test-suite debug-test+    type: exitcode-stdio-1.0+    main-is: testDebug.hs+    hs-source-dirs: test+    build-depends: peyotls, handle-like == 0.1.*,+        base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,+        x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*,+        random == 1.0.*+    ghc-options: -Wall++test-suite reneg-test+    type: exitcode-stdio-1.0+    main-is: testReneg.hs+    hs-source-dirs: test+    build-depends: peyotls, handle-like == 0.1.*,+        base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,+        x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*,+        random == 1.0.*+    ghc-options: -Wall++test-suite ci-reneg-test+    type: exitcode-stdio-1.0+    main-is: testCIRenego.hs+    hs-source-dirs: test+    build-depends: peyotls, handle-like == 0.1.*,+        base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,+        x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*,+        random == 1.0.*     ghc-options: -Wall

@@ -1,17 +1,19 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,+	UndecidableInstances, PackageImports, ScopedTypeVariables #-}  module Network.PeyoTLS.Client (-	run, open, names,+	PeyotlsM, PeyotlsHandleC,+	TlsM, TlsHandleC,+	run, open, renegotiate, names, 	CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	PeyotlsM, PeyotlsHandle,-	TlsM, TlsHandle, 	ValidateHandle(..), CertSecretKey ) where  import Control.Applicative ((<$>), (<*>))-import Control.Monad (unless, liftM, ap)+import Control.Monad (when, unless, liftM) import Data.List (find, intersect)-import Data.HandleLike (HandleLike)-import "crypto-random" Crypto.Random (CPRG)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG, SystemRNG)  import qualified "monads-tf" Control.Monad.Error as E import qualified "monads-tf" Control.Monad.Error.Class as E@@ -30,12 +32,19 @@ import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import Network.PeyoTLS.HandshakeBase (-	PeyotlsM, PeyotlsHandle, names,-	TlsM, run, HandshakeM, execHandshakeM, CertSecretKey(..),+import qualified Network.PeyoTLS.HandshakeBase as HB+import Network.PeyoTLS.HandshakeBase ( flushAppData,+	Extension(..), getClientFinished, Finished(..),+	getInitSet, setInitSet,+	setClientFinished, getClientFinished,+	setServerFinished, getServerFinished,+	PeyotlsM, PeyotlsHandle,+	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM,+		CertSecretKey(..), 		withRandom, randomByteString, 	TlsHandle, 		readHandshake, getChangeCipherSpec,+		readHandshakeNoHash, 		writeHandshake, putChangeCipherSpec, 	ValidateHandle(..), handshakeValidate, 	ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..),@@ -48,13 +57,43 @@ 		generateKeys, encryptRsa, rsaPadding, 	DigitallySigned(..), handshakeHash, flushCipherSuite, 	Side(..), RW(..), finishedHash,-	DhParam(..), generateKs, blindSign )+	DhParam(..), generateKs, blindSign, +	hlGetRn, hlGetLineRn, hlGetContentRn,+	)++names :: TlsHandleC h g -> [String]+names = HB.names . tlsHandleC+ open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> 	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	TlsM h g (TlsHandle h g)-open h cscl crts ca = execHandshakeM h $ do-	(cr, sr, cs@(CipherSuite ke _)) <- hello cscl+	TlsM h g (TlsHandleC h g)+open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do+	setInitSet (cscl, crts, Just ca)+	cr <- clientHello cscl+	handshake crts ca cr++renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleC h g -> TlsM h g ()+renegotiate (TlsHandleC t) = rerunHandshakeM t $ do+	(cscl, crts, Just ca) <- getInitSet+	cr <- clientHello cscl+	(ret, ne) <- flushAppData+	bf <- HB.getAdBufH+	HB.setAdBufH $ bf `BS.append` ret+	when ne $ handshake crts ca cr++rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+rehandshake t = rerunHandshakeM t $ do+	(cscl, crts, Just ca) <- getInitSet+	cr <- clientHello cscl+	handshake crts ca cr+	return ()++handshake :: (ValidateHandle h, CPRG g) =>+	[(CertSecretKey, X509.CertificateChain)] ->+	X509.CertificateStore -> BS.ByteString -> HandshakeM h g ()+handshake crts ca cr = do+	(sr, cs@(CipherSuite ke _)) <- serverHello 	setCipherSuite cs 	case ke of 		RSA -> rsaHandshake cr sr crts ca@@ -66,18 +105,32 @@ 	dhType :: DH.Params; dhType = undefined 	curveType :: ECC.Curve; curveType = undefined -hello :: (HandleLike h, CPRG g) =>-	[CipherSuite] -> HandshakeM h g (BS.ByteString, BS.ByteString, CipherSuite)-hello cscl = do+getRenegoInfo :: Maybe [Extension] -> Maybe BS.ByteString+getRenegoInfo Nothing = Nothing+getRenegoInfo (Just []) = Nothing+getRenegoInfo (Just (ERenegoInfo rn : _)) = Just rn+getRenegoInfo (Just (_ : es)) = getRenegoInfo $ Just es++clientHello :: (HandleLike h, CPRG g) =>+	[CipherSuite] -> HandshakeM h g BS.ByteString+clientHello cscl = do 	cr <- randomByteString 32-	writeHandshake $ ClientHello (3, 3) cr (SessionId "")-		cscl' [CompressionMethodNull] Nothing-	ServerHello _v sr _sid cs _cm _e <- readHandshake-	return (cr, sr, cs)-	where-	cscl' = if b `elem` cscl then cscl else cscl ++ [b]-	b = CipherSuite RSA AES_128_CBC_SHA+	cf <- getClientFinished+	writeHandshake . ClientHello (3, 3) cr (SessionId "") cscl+		[CompressionMethodNull] $ Just [ERenegoInfo cf]+	return cr +serverHello :: (HandleLike h, CPRG g) =>+	HandshakeM h g (BS.ByteString, CipherSuite)+serverHello = do+	cf <- getClientFinished+	sf <- getServerFinished+	ServerHello _v sr _sid cs _cm e <- readHandshake+	let	Just rn = getRenegoInfo e+		rn0 = cf `BS.append` sf+	unless (rn == rn0) $ E.throwError "Network.PeyoTLS.Client.hello"+	return (sr, cs)+ rsaHandshake :: (ValidateHandle h, CPRG g) =>  	BS.ByteString -> BS.ByteString -> 	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->@@ -218,9 +271,13 @@ 			writeHandshake $ digitallySigned sk (pubKey sk c) hs 		_ -> return () 	putChangeCipherSpec >> flushCipherSuite Write-	writeHandshake =<< finishedHash Client+	fc@(Finished fcb) <- finishedHash Client+	writeHandshake fc+	setClientFinished fcb 	getChangeCipherSpec >> flushCipherSuite Read-	(==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless+	fs@(Finished fsb) <- finishedHash Server+	setServerFinished fsb+	(fs ==) `liftM` readHandshake >>= flip unless 		(E.throwError "TlsClient.finishHandshake: finished hash failure") 	where 	digitallySigned sk pk hs = DigitallySigned (algorithm sk) $ sign sk pk hs@@ -251,3 +308,46 @@ 				ASN1.IntVal r, ASN1.IntVal s, 				ASN1.End ASN1.Sequence] 	algorithm _ = (Sha256, Ecdsa)++newtype TlsHandleC h g = TlsHandleC { tlsHandleC :: TlsHandle h g }++instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleC h g) where+	type HandleMonad (TlsHandleC h g) = HandleMonad (TlsHandle h g)+	type DebugLevel (TlsHandleC h g) = DebugLevel (TlsHandle h g)+	hlPut (TlsHandleC t) = hlPut t+	hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleC+	hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleC+	hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleC+	hlDebug (TlsHandleC t) = hlDebug t+	hlClose (TlsHandleC t) = hlClose t++hlGet_ :: (ValidateHandle h, CPRG g) =>+	TlsHandleC h g -> Int -> TlsM h g BS.ByteString+hlGet_ (TlsHandleC t) n = do+	bf <- HB.getAdBuf t+	if (BS.length bf >= 0)+	then do	let (ret, rest) = BS.splitAt n bf+		HB.setAdBuf t rest+		return ret+	else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf)++hlGetLine_ :: (ValidateHandle h, CPRG g) =>+	TlsHandleC h g -> TlsM h g BS.ByteString+hlGetLine_ (TlsHandleC t) = do+	bf <- HB.getAdBuf t+	if (10 `BS.elem` bf)+	then do	let (ret, rest) = BS.span (/= 10) bf+		HB.setAdBuf t $ BS.tail rest+		return ret+	else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t++hlGetContent_ :: (ValidateHandle h, CPRG g) =>+	TlsHandleC h g -> TlsM h g BS.ByteString+hlGetContent_ (TlsHandleC t) = do+	bf <- HB.getAdBuf t+	if BS.null bf+	then hlGetContentRn rehandshake t+	else do	HB.setAdBuf t ""+		return bf++type PeyotlsHandleC = TlsHandleC Handle SystemRNG

@@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports, 	TupleSections #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Network.PeyoTLS.HandshakeBase ( Extension(..), 	PeyotlsM, PeyotlsHandle, 	debug, generateKs, blindSign, CertSecretKey(..),-	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.oldHandshakeM,+	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM, 	HM.withRandom, HM.randomByteString, 	HM.TlsHandle, HM.names, 		readHandshake, getChangeCipherSpec,+		readHandshakeNoHash, 		writeHandshake, putChangeCipherSpec,+		writeHandshakeNoHash, 	HM.ValidateHandle(..), HM.handshakeValidate, 	HM.Alert(..), HM.AlertLevel(..), HM.AlertDesc(..), 	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),@@ -28,14 +31,16 @@ 	HM.getServerFinished, HM.setServerFinished, 	Finished(..), 	HM.ContentType(CTAlert, CTHandshake, CTAppData),-	HM.tlsPut_, 	Handshake(..), 	HM.tlsHandle,-	HM.tGetContent_,-	HM.tlsGet_,-	HM.tGetLine_,+	hlGetRn, hlGetLineRn, hlGetContentRn,  	HM.getInitSet, HM.setInitSet,+	HM.flushAppData,+	HM.getAdBuf,+	HM.setAdBuf,+	HM.getAdBufH,+	HM.setAdBufH, 	) where  import Control.Applicative@@ -76,25 +81,29 @@ 	ServerHelloDone(..), ClientKeyExchange(..), Epms(..), 	DigitallySigned(..), Finished(..) ) import qualified Network.PeyoTLS.HandshakeMonad as HM (-	TlsM, run, HandshakeM, execHandshakeM, oldHandshakeM,+	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, 	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate, 	TlsHandle(..), ContentType(..), 		names, 		setCipherSuite, flushCipherSuite, debugCipherSuite,-		tlsGetContentType, tlsGet, tlsPut,+		tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash, 		generateKeys, encryptRsa, decryptRsa, rsaPadding, 	Alert(..), AlertLevel(..), AlertDesc(..), 	Side(..), RW(..), handshakeHash, finishedHash, throwError, 	hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_, 	tGetLine_, tGetContent_, tlsGet__,---	hlGet_, hlGetLine_, hlGetContent_, 	hlDebug_, hlClose_, 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished, 	resetSequenceNumber,  	getInitSet, setInitSet,+	flushAppData,+	getAdBuf,+	setAdBuf,+	getAdBufH,+	setAdBufH, 	) import Network.PeyoTLS.Ecdsa (blindSign, generateKs) @@ -110,21 +119,38 @@  readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi readHandshake = do-	cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+	cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType 	hs <- case cnt of+		CHandshake HHelloRequest -> readHandshake 		CHandshake hs -> return hs 		_ -> HM.throwError-			HM.ALFatal HM.ADUnexpectedMessage-			"HandshakeBase.readHandshake: not handshake"+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.readHandshake: not handshake: " ++ show cnt 	case fromHandshake hs of 		Just i -> return i 		_ -> HM.throwError 			HM.ALFatal HM.ADUnexpectedMessage $ 			"HandshakeBase.readHandshake: type mismatch " ++ show hs -writeHandshake ::+readHandshakeNoHash :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi+readHandshakeNoHash = do+	cnt <- readContent (HM.tlsGet False) =<< HM.tlsGetContentType+	hs <- case cnt of+		CHandshake hs -> return hs+		_ -> HM.throwError+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.readHandshake: not handshake: " ++ show cnt+	case fromHandshake hs of+		Just i -> return i+		_ -> HM.throwError+			HM.ALFatal HM.ADUnexpectedMessage $+			"HandshakeBase.readHandshake: type mismatch " ++ show hs++writeHandshake, writeHandshakeNoHash :: 	(HandleLike h, CPRG g, HandshakeItem hi) => hi -> HM.HandshakeM h g () writeHandshake = uncurry HM.tlsPut . encodeContent . CHandshake . toHandshake+writeHandshakeNoHash =+	uncurry HM.tlsPutNoHash . encodeContent . CHandshake . toHandshake  data ChangeCipherSpec = ChangeCipherSpec | ChangeCipherSpecRaw Word8 deriving Show @@ -138,7 +164,7 @@  getChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g () getChangeCipherSpec = do-	cnt <- readContent HM.tlsGet =<< HM.tlsGetContentType+	cnt <- readContent (HM.tlsGet True) =<< HM.tlsGetContentType 	case cnt of 		CCCSpec ChangeCipherSpec -> return () 		_ -> HM.throwError@@ -255,9 +281,7 @@ 	type Secret ECC.Curve = Integer 	type Public ECC.Curve = ECC.Point 	generateSecret c = getRangedInteger 32 1 (n - 1)-		-- first (either error id . B.decode) . cprgGenerate 64-		where-		n = ECC.ecc_n $ ECC.common_curve c+		where n = ECC.ecc_n $ ECC.common_curve c 	calculatePublic cv sn = 		ECC.pointMul cv sn . ECC.ecc_g $ ECC.common_curve cv 	calculateShared cv sn pp =@@ -278,21 +302,13 @@ 	type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g 	type DebugLevel (HM.TlsHandle h g) = DebugLevel h 	hlPut = HM.hlPut_-	hlGet = hlGet_-	hlGetLine = hlGetLine_-	hlGetContent = hlGetContent_+	hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .)+		. HM.tlsGet__ . (, undefined)+	hlGetLine = ($) <$> checkAppData <*> HM.tGetLine+	hlGetContent = ($) <$> checkAppData <*> HM.tGetContent 	hlDebug = HM.hlDebug_ 	hlClose = HM.hlClose_ -hlGet_ :: (HandleLike h, CPRG g) =>-	(HM.TlsHandle h g) -> Int -> HM.TlsM h g BS.ByteString-hlGet_ = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet__ . (, undefined)--hlGetLine_, hlGetContent_ ::-	(HandleLike h, CPRG g) => (HM.TlsHandle h g) -> HM.TlsM h g BS.ByteString-hlGetLine_ = ($) <$> checkAppData <*> HM.tGetLine-hlGetContent_ = ($) <$> checkAppData <*> HM.tGetContent- checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g -> 	HM.TlsM h g (HM.ContentType, BS.ByteString) -> HM.TlsM h g BS.ByteString checkAppData t m = m >>= \cp -> case cp of@@ -301,10 +317,21 @@ 		_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL" 		E.throwError "TlsHandle.checkAppData: EOF" 	(HM.CTHandshake, hs) -> do-		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?"-		lift . lift $ hlDebug (HM.tlsHandle t) "critical" . BSC.pack $ show hs-		lift . lift $ hlDebug (HM.tlsHandle t) "critical" . BSC.pack .-			show $ (B.decode hs :: Either String Handshake)+		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n"+		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack+			. (++ "\n") $ show hs+		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack+			. (++ "\n") $ show (B.decode hs :: Either String Handshake) 		return "" 	_ -> do	_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10" 		E.throwError "TlsHandle.checkAppData: not application data"++hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->+	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString+hlGetRn rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh+	. (, undefined)++hlGetLineRn, hlGetContentRn :: (HM.ValidateHandle h, CPRG g) =>+	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString+hlGetLineRn rh = ($) <$> checkAppData <*> HM.tGetLine_ rh+hlGetContentRn rh = ($) <$> checkAppData <*> HM.tGetContent_ rh

@@ -1,26 +1,28 @@ {-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-}  module Network.PeyoTLS.HandshakeMonad (-	TH.TlsM, TH.run, HandshakeM, execHandshakeM, oldHandshakeM,+	TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, 	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate, 	TH.TlsHandle(..), TH.ContentType(..), 		setCipherSuite, flushCipherSuite, debugCipherSuite,-		tlsGetContentType, tlsGet, tlsPut,+		tlsGetContentType, tlsGet, tlsPut, tlsPutNoHash, 		generateKeys, encryptRsa, decryptRsa, rsaPadding, 	TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..), 	TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError, 	TH.hlPut_, TH.hlDebug_, TH.hlClose_, 	TH.tGetLine, TH.tGetContent, tlsGet_, tlsPut_, tlsGet__, 	tGetLine_, tGetContent_,---	checkAppData,---	hlGet_, hlGetLine_, hlGetContent_, 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished,  	resetSequenceNumber,  	getInitSet, setInitSet,+	flushAppData,++	getAdBuf, setAdBuf,+	getAdBufH, setAdBufH, 	) where  import Prelude hiding (read)@@ -30,7 +32,8 @@ import Control.Arrow (first) import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift)-import "monads-tf" Control.Monad.State (StateT, execStateT, get, gets, put, modify)+import "monads-tf" Control.Monad.State (+	StateT, evalStateT, execStateT, get, gets, put, modify) import qualified "monads-tf" Control.Monad.Error as E (throwError) import "monads-tf" Control.Monad.Error.Class (strMsg) import Data.HandleLike (HandleLike(..))@@ -54,13 +57,17 @@ 		debugCipherSuite, 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, 	Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..),-	hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine,+	hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine, tGetLine_, 	getClientFinishedT, setClientFinishedT, 	getServerFinishedT, setServerFinishedT,  	resetSequenceNumber,  	getInitSetT, setInitSetT, InitialSettings,+	tlsGet_,+	flushAppData,+	getAdBufT,+	setAdBufT, 	)  resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g ()@@ -69,27 +76,20 @@ tlsGet_ :: (HandleLike h, CPRG g) => 	(TH.TlsHandle h g -> TH.TlsM h g ()) -> 	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))-tlsGet_ rn th@(t, _) n = do-	ct <- TH.getContentType t-	case ct of-		TH.CTHandshake -> do-			rn t-			tlsGet_ rn th n-		_ -> TH.tlsGet th n+tlsGet_ = TH.tlsGet_  tlsGet__ :: (HandleLike h, CPRG g) => 	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))-tlsGet__ = TH.tlsGet+tlsGet__ = TH.tlsGet True  tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) => 	(TH.TlsHandle h g -> TH.TlsM h g ()) -> 	TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)-tGetLine_ rn t = do-	ct <- TH.getContentType t-	case ct of-		TH.CTHandshake -> rn t >> tGetLine_ rn t-		_ -> TH.tGetLine t+tGetLine_ = TH.tGetLine_ +flushAppData :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)+flushAppData = gets fst >>= lift . TH.flushAppData+ tGetContent_ rn t = do 	ct <- TH.getContentType t 	case ct of@@ -98,7 +98,7 @@  tlsPut_ :: (HandleLike h, CPRG g) => 	(TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx)-tlsPut_ = TH.tlsPut+tlsPut_ = TH.tlsPut True  throwError :: HandleLike h => 	TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a@@ -111,9 +111,9 @@ execHandshakeM h = 	liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT -oldHandshakeM :: HandleLike h => TH.TlsHandle h g -> BS.ByteString ->-	HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g)-oldHandshakeM t bs hm = fst `liftM` execStateT hm (t, SHA256.update SHA256.init bs)+rerunHandshakeM ::+	HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a+rerunHandshakeM t hm = evalStateT hm (t, SHA256.init)  withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a withRandom = lift . TH.withRandom@@ -150,9 +150,8 @@ 	X509.CertificateStore -> X509.CertificateChain -> 	HandshakeM h g [X509.FailedReason] handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do-	modify . first $ const t { TH.names = certNames $ X509.getCertificate $ last c }+	modify . first $ const t { TH.names = certNames . X509.getCertificate $ last c } 	lift . lift . lift $ validate (TH.tlsHandle t) cs cc--- handshakeValidate _ _ = error "empty certificate chain"  setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g () setCipherSuite cs = do@@ -170,12 +169,13 @@ tlsGetContentType :: (HandleLike h, CPRG g) => HandshakeM h g TH.ContentType tlsGetContentType = gets fst >>= lift . TH.getContentType -tlsGet :: (HandleLike h, CPRG g) => Int -> HandshakeM h g BS.ByteString-tlsGet n = do ((_, bs), t') <- lift . flip TH.tlsGet n =<< get; put t'; return bs+tlsGet :: (HandleLike h, CPRG g) => Bool -> Int -> HandshakeM h g BS.ByteString+tlsGet b n = do ((_, bs), t') <- lift . flip (TH.tlsGet b) n =<< get; put t'; return bs -tlsPut :: (HandleLike h, CPRG g) =>+tlsPut, tlsPutNoHash :: (HandleLike h, CPRG g) => 	TH.ContentType -> BS.ByteString -> HandshakeM h g ()-tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut t ct bs) >>= put+tlsPut ct bs = get >>= lift . (\t -> TH.tlsPut True t ct bs) >>= put+tlsPutNoHash ct bs = get >>= lift . (\t -> TH.tlsPut False t ct bs) >>= put  generateKeys :: HandleLike h => TH.Side -> 	(BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g ()@@ -184,7 +184,6 @@ 	cs <- lift $ TH.getCipherSuiteSt (TH.clientId t) 	k <- lift $ TH.generateKeys t p cs cr sr pms 	lift $ TH.setKeys (TH.clientId t) k---	modify . first $ const t { TH.keys = k }  encryptRsa :: (HandleLike h, CPRG g) => 	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString@@ -221,3 +220,18 @@  setInitSet :: HandleLike h => TH.InitialSettings -> HandshakeM h g () setInitSet is = gets fst >>= lift . flip TH.setInitSetT is++-- getAdBuf :: HandleLike h => HandshakeM h g BS.ByteString+getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString+getAdBuf = TH.getAdBufT -- = gets fst >>= lift . TH.getAdBufT++-- setAdBuf :: HandleLike h => BS.ByteString -> HandshakeM h g ()+setAdBuf :: HandleLike h =>+	TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g ()+setAdBuf = TH.setAdBufT -- bs = gets fst >>= lift . flip TH.setAdBufT bs++getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString+getAdBufH = gets fst >>= lift . TH.getAdBufT++setAdBufH :: HandleLike h => BS.ByteString -> HandshakeM h g ()+setAdBufH bs = gets fst >>= lift . flip TH.setAdBufT bs

@@ -13,6 +13,7 @@ 	DigitallySigned(..), Finished(..) ) where  import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless) import Data.Word (Word8, Word16) import Data.Word.Word24 (Word24) @@ -31,7 +32,8 @@ 	ClientKeyExchange(..), DigitallySigned(..) )  data Handshake-	= HClientHello ClientHello           | HServerHello ServerHello+	= HHelloRequest+	| HClientHello ClientHello           | HServerHello ServerHello 	| HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString 	| HCertificateReq CertificateRequest | HServerHelloDone 	| HCertVerify DigitallySigned        | HClientKeyEx ClientKeyExchange@@ -46,6 +48,9 @@ 		t <- B.take 1 		len <- B.take 3 		case t of+			THelloRequest -> do+				unless (len == 0) $ fail "parse Handshake"+				return HHelloRequest 			TClientHello -> HClientHello <$> B.take len 			TServerHello -> HServerHello <$> B.take len 			TCertificate -> HCertificate <$> B.take len@@ -58,6 +63,7 @@ 			_ -> HRaw t <$> B.take len  encodeH :: Handshake -> BS.ByteString+encodeH HHelloRequest = encodeH $ HRaw THelloRequest "" encodeH (HClientHello ch) = encodeH . HRaw TClientHello $ B.encode ch encodeH (HServerHello sh) = encodeH . HRaw TServerHello $ B.encode sh encodeH (HCertificate crts) = encodeH . HRaw TCertificate $ B.encode crts@@ -70,9 +76,11 @@ encodeH (HRaw t bs) = B.encode t `BS.append` B.addLen (undefined :: Word24) bs  class HandshakeItem hi where-	fromHandshake :: Handshake -> Maybe hi;-	toHandshake :: hi -> Handshake+	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@@ -200,13 +208,14 @@ data ServerHelloDone = ServerHelloDone deriving Show  data Type-	= TClientHello | TServerHello-	| TCertificate | TServerKeyEx | TCertificateReq | TServerHelloDone-	| TCertVerify  | TClientKeyEx | TFinished       | TRaw Word8+	= 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@@ -218,6 +227,7 @@ 		[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]

@@ -1,26 +1,22 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, FlexibleContexts,-	PackageImports, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+	UndecidableInstances, PackageImports #-}  module Network.PeyoTLS.Server (-	run, open, names,+	PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS,+	run, open, renegotiate, names, 	CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	PeyotlsM, PeyotlsHandle,-	TlsM, TlsHandle, 	ValidateHandle(..), CertSecretKey ) where -import Control.Applicative-import Control.Monad (unless, liftM, ap)-import "monads-tf" Control.Monad.Error (catchError, lift)-import qualified "monads-tf" Control.Monad.Error as E (throwError)-import "monads-tf" Control.Monad.Error.Class (strMsg)+import Control.Monad (when, unless, liftM, ap) import Data.List (find) import Data.Word (Word8) import Data.HandleLike (HandleLike(..))-import "crypto-random" Crypto.Random (CPRG)+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG, SystemRNG) +import qualified "monads-tf" Control.Monad.Error as E+import qualified "monads-tf" Control.Monad.Error.Class as E import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 import qualified Data.X509.CertificateStore as X509@@ -32,85 +28,108 @@ import qualified Crypto.PubKey.ECC.ECDSA as ECDSA  import qualified Network.PeyoTLS.HandshakeBase as HB--import Network.PeyoTLS.HandshakeBase ( debug, Extension(..),-	PeyotlsM, PeyotlsHandle,-	TlsM, run, HandshakeM, execHandshakeM, oldHandshakeM,-	withRandom, randomByteString,-	TlsHandle,+import Network.PeyoTLS.HandshakeBase (+	PeyotlsM, TlsM, run,+	HandshakeM, execHandshakeM, rerunHandshakeM,+		setCipherSuite, withRandom, randomByteString,+	ValidateHandle(..), handshakeValidate,+	TlsHandle, CertSecretKey(..), 		readHandshake, getChangeCipherSpec, 		writeHandshake, putChangeCipherSpec,-	ValidateHandle(..), handshakeValidate,+		writeHandshakeNoHash, 	AlertLevel(..), AlertDesc(..),-	ServerKeyExchange(..), ServerHelloDone(..),-	ClientHello(..), ServerHello(..), SessionId(..),+	ClientHello(..), ServerHello(..), SessionId(..), Extension(..), 		CipherSuite(..), KeyExchange(..), BulkEncryption(..), 		CompressionMethod(..), HashAlg(..), SignAlg(..),-		setCipherSuite,+		getClientFinished, setClientFinished,+		getServerFinished, setServerFinished,+	ServerKeyExchange(..), 	certificateRequest, ClientCertificateType(..), SecretKey(..),+	ServerHelloDone(..), 	ClientKeyExchange(..), Epms(..), 		generateKeys, decryptRsa, rsaPadding, debugCipherSuite, 	DigitallySigned(..), handshakeHash, flushCipherSuite,-	Side(..), RW(..), finishedHash,+	Finished(..), Side(..), RW(..), finishedHash, 	DhParam(..), dh3072Modp, secp256r1, throwError,-	CertSecretKey(..),-	getClientFinished, setClientFinished,-	getServerFinished, setServerFinished,-	Finished(..),-	ContentType(..),-	tlsPut_, Handshake(..), tlsHandle, tGetContent_,-	tlsGet_, tGetLine_,-	) -import System.IO.Unsafe-import Network.PeyoTLS.ReadFile--cipherSuites :: [CipherSuite]-cipherSuites = [-	"TLS_RSA_WITH_AES_128_CBC_SHA"-	]+	hlGetRn, hlGetLineRn, hlGetContentRn, debug ) -certificateSets :: [(CertSecretKey, X509.CertificateChain)]-certificateSets = unsafePerformIO $ do-	k <- readKey "rsa2048.sample_key"-	c <- readCertificateChain "rsa2048.sample_crt"-	return [(k, c)]+type PeyotlsHandleS = TlsHandleS Handle SystemRNG  names :: TlsHandleS h g -> [String] names = HB.names . tlsHandleS -type Version = (Word8, Word8)--version :: Version-version = (3, 3)--filterCS :: [(CertSecretKey, X509.CertificateChain)] ->-	[CipherSuite] -> [CipherSuite]-filterCS crts cs = case find isEcdsa crts of-	Just _ -> cs-	_ -> filter (not . isEcdsaCS) cs--isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool-isEcdsa (EcdsaKey _, _) = True-isEcdsa _ = False--isRsa :: (CertSecretKey, X509.CertificateChain) -> Bool-isRsa (RsaKey _, _) = True-isRsa _ = False--isEcdsaCS :: CipherSuite -> Bool-isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True-isEcdsaCS _ = False--open :: (ValidateHandle h, CPRG g) => h ->-	[CipherSuite] ->-	[(CertSecretKey, X509.CertificateChain)] ->+open :: (ValidateHandle h, CPRG g) =>+	h -> [CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] -> 	Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g) open h cssv crts mcs = (TlsHandleS `liftM`) . execHandshakeM h $ do 	HB.setInitSet (cssv, crts, mcs) 	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv 	succeed cs cr cv crts mcs rn +renegotiate ::+	(ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g ()+renegotiate (TlsHandleS t) = rerunHandshakeM t $ do+	writeHandshakeNoHash HB.HHelloRequest+	(ret, ne) <- HB.flushAppData+	bf <- HB.getAdBufH+	HB.setAdBufH $ bf `BS.append` ret+	when ne $ handshake++rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+rehandshake t = rerunHandshakeM t handshake++handshake :: (ValidateHandle h, CPRG g) => HandshakeM h g ()+handshake = do+	(cssv, crts, mcs) <- HB.getInitSet+	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv+	succeed cs cr cv crts mcs rn++clientHello :: (HandleLike h, CPRG g) =>+	[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool)+clientHello cssv = do+	cf0 <- getClientFinished+	ch@(ClientHello cv cr _sid cscl cms me) <- readHandshake+	let (cf, rn) = case me of+		Nothing -> ("", False)+		Just e -> case getRenegoInfo cscl e of+			Nothing -> ("", False)+			Just c -> (c, True)+	debug "medium" ch+	unless (cf == cf0) $ E.throwError "clientHello"+	chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn)+	where+	merge sv cl = case find (`elem` cl) sv of+		Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA+	chk cv _css cms+		| cv < version = throwError ALFatal ADProtocolVersion $+			pmsg ++ "client version should 3.3 or more"+		| CompressionMethodNull `notElem` cms =+			throwError ALFatal ADDecodeError $+				pmsg ++ "compression method NULL must be supported"+		| otherwise = return ()+		where pmsg = "TlsServer.clientHello: "+	getRenegoInfo [] [] = Nothing+	getRenegoInfo (TLS_EMPTY_RENEGOTIATION_INFO_SCSV : _) _ = Just ""+	getRenegoInfo (_ : css) e = getRenegoInfo css e+	getRenegoInfo [] (ERenegoInfo rn : _) = Just rn+	getRenegoInfo [] (_ : es) = getRenegoInfo [] es++serverHello :: (HandleLike h, CPRG g) => CipherSuite ->+	X509.CertificateChain -> X509.CertificateChain -> Bool ->+	HandshakeM h g BS.ByteString+serverHello cs@(CipherSuite ke _) rcc ecc rn = do+	sr <- randomByteString 32+	cf <- getClientFinished+	sf <- getServerFinished+	writeHandshake . ServerHello+		version sr (SessionId "") cs CompressionMethodNull $ if rn+			then Just [ERenegoInfo $ cf `BS.append` sf]+			else Nothing+	writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc+	return sr+serverHello _ _ _ _ = E.throwError "TlsServer.serverHello: never occur"+ succeed :: (ValidateHandle h, CPRG g) => CipherSuite -> BS.ByteString -> 	Version -> [(CertSecretKey, X509.CertificateChain)] -> 	Maybe X509.CertificateStore -> Bool -> HandshakeM h g ()@@ -121,25 +140,23 @@ 		AES_128_CBC_SHA -> return Sha1 		AES_128_CBC_SHA256 -> return Sha256 		_ -> E.throwError-			"TlsServer.open: not implemented bulk encryption type"---	debug "medium" . RSA.public_size $ RSA.private_pub rsk+			"TlsServer.succeed: not implemented bulk encryption type" 	mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of 		RSA -> rsaKeyExchange rsk cv 		DHE_RSA -> dhKeyExchange ha dh3072Modp rsk 		ECDHE_RSA -> dhKeyExchange ha secp256r1 rsk 		ECDHE_ECDSA -> dhKeyExchange ha secp256r1 esk 		_ -> \_ _ -> E.throwError-			"TlsServer.open: not implemented key exchange type"+			"TlsServer.succeed: not implemented key exchange type" 	maybe (return ()) certificateVerify mpk-	debug "low" ("before getChangeCipherSpec" :: String) 	getChangeCipherSpec >> flushCipherSuite Read 	cf@(Finished cfb) <- finishedHash Client-	debug "low" ("client finished" :: String)-	debug "low" cf 	rcf <- readHandshake+	debug "low" ("client finished hash" :: String)+	debug "low" cf 	debug "low" rcf 	unless (cf == rcf) $ throwError ALFatal ADDecryptError-		"TlsServer.open: wrong finished hash"+		"TlsServer.succeed: wrong finished hash" 	setClientFinished cfb 	putChangeCipherSpec >> flushCipherSuite Write 	sf@(Finished sfb) <- finishedHash Server@@ -148,6 +165,9 @@ 	where 	Just (RsaKey rsk, rcc) = find isRsa crts 	Just (EcdsaKey esk, ecc) = find isEcdsa crts+	isRsa (RsaKey _, _) = True+	isRsa _ = False+succeed _ _ _ _ _ _ = E.throwError "Network.PeyoTLS.Server.succeed: not implemented"  rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> 	(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->@@ -169,74 +189,6 @@ 		`ap` requestAndCertificate mcs 		`ap` dhClientKeyExchange dp sv rs -fromClientHello :: [CipherSuite] -> Handshake -> (CipherSuite, BS.ByteString, Version, Bool)-fromClientHello cssv (HClientHello (ClientHello cv cr _sid cscl _cms _e)) =-	(merge cssv cscl, cr, cv, True)-	where-	merge sv cl = case find (`elem` cl) sv of-		Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA-fromClientHello _ _ = error "Server.fromClientHello: bad"--getRenegoInfo :: [CipherSuite] -> [Extension] -> Maybe BS.ByteString-getRenegoInfo [] [] = Nothing-getRenegoInfo (TLS_EMPTY_RENEGOTIATION_INFO_SCSV : _) _ = Just ""-getRenegoInfo (_ : css) e = getRenegoInfo css e-getRenegoInfo [] (ERenegoInfo rn : _) = Just rn-getRenegoInfo [] (_ : es) = getRenegoInfo [] es--clientHello :: (HandleLike h, CPRG g) =>-	[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool)-clientHello cssv = do-	cf0 <- getClientFinished-	ch@(ClientHello cv cr _sid cscl cms me) <- readHandshake---	let Just cf = getRenegoInfo me---	let rn = True-	let (cf, rn) = case me of-		Nothing -> ("", False)-		Just e -> case getRenegoInfo cscl e of-			Nothing -> ("", False)-			Just c -> (c, True)-	debug "medium" ch---	debug "medium" e---	let rn = maybe False (ERenegoInfo "" `elem`) e---	debug "medium" rn-	debug "low" "CLIENT FINISHES"-	debug "low" cf-	debug "low" cf0-	unless (cf == cf0) $ E.throwError "clientHello"-	chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn)-	where-	merge sv cl = case find (`elem` cl) sv of-		Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA-	chk cv _css cms-		| cv < version = throwError ALFatal ADProtocolVersion $-			pmsg ++ "client version should 3.3 or more"-			{--		| CipherSuite RSA AES_128_CBC_SHA `notElem` css =-			throwError ALFatal ADIllegalParameter $-				pmsg ++ "TLS_RSA_AES_128_CBC_SHA must be supported"-				-}-		| CompressionMethodNull `notElem` cms =-			throwError ALFatal ADDecodeError $-				pmsg ++ "compression method NULL must be supported"-		| otherwise = return ()-		where pmsg = "TlsServer.clientHello: "--serverHello :: (HandleLike h, CPRG g) => CipherSuite ->-	X509.CertificateChain -> X509.CertificateChain -> Bool ->-	HandshakeM h g BS.ByteString-serverHello cs@(CipherSuite ke _) rcc ecc rn = do-	sr <- randomByteString 32-	cf <- getClientFinished-	sf <- getServerFinished-	writeHandshake . ServerHello-		version sr (SessionId "") cs CompressionMethodNull $ if rn-			then Just [ERenegoInfo $ cf `BS.append` sf]-			else Nothing-	writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc-	return sr-serverHello _ _ _ _ = E.throwError "TlsServer.serverHello: never occur"- serverKeyExchange :: (HandleLike h, CPRG g, SecretKey sk, 		DhParam dp, B.Bytable dp, B.Bytable (Public dp)) => 	HashAlg -> dp -> Secret dp -> sk ->@@ -262,7 +214,7 @@ 	X509.CertificateStore -> HandshakeM h g X509.PubKey clientCertificate cs = do 	cc@(X509.CertificateChain (c : _)) <- readHandshake-	chk cc -- >> setClientNames (certNames $ X509.getCertificate c)+	chk cc 	return . X509.certPubKey $ X509.getCertificate c 	where 	chk cc = do@@ -281,7 +233,7 @@ 	Epms epms <- readHandshake 	debug "low" ("EPMS" :: String) 	debug "low" epms-	generateKeys Server rs =<< mkpms epms `catchError` const+	generateKeys Server rs =<< mkpms epms `E.catchError` const 		((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46) 	where 	mkpms epms = do@@ -302,7 +254,7 @@ 	ClientKeyExchange cke <- readHandshake 	let Right pv = B.decode cke 	generateKeys Server rs =<< case Right $ calculateShared dp sv pv of-		Left em -> E.throwError . strMsg $+		Left em -> E.throwError . E.strMsg $ 			"TlsServer.dhClientKeyExchange: " ++ em 		Right sh -> return sh @@ -343,58 +295,55 @@ 	type HandleMonad (TlsHandleS h g) = HandleMonad (TlsHandle h g) 	type DebugLevel (TlsHandleS h g) = DebugLevel (TlsHandle h g) 	hlPut (TlsHandleS t) = hlPut t-	hlGet = hlGet_-	hlGetLine = hlGetLine_-	hlGetContent = hlGetContent_+	hlGet = hlGet_ -- hlGetRn rehandshake . tlsHandleS+	hlGetLine = hlGetLine_ -- hlGetLineRn rehandshake . tlsHandleS+	hlGetContent = hlGetContent_ -- hlGetContentRn rehandshake . tlsHandleS 	hlDebug (TlsHandleS t) = hlDebug t 	hlClose (TlsHandleS t) = hlClose t  hlGet_ :: (ValidateHandle h, CPRG g) => 	TlsHandleS h g -> Int -> TlsM h g BS.ByteString-hlGet_ = (.) <$> checkAppData <*> ((fst `liftM`) .) . tlsGet_ rehandshake-	. (, undefined) . tlsHandleS+hlGet_ (TlsHandleS t) n = do+	bf <- HB.getAdBuf t+	if (BS.length bf >= 0)+	then do	let (ret, rest) = BS.splitAt n bf+		HB.setAdBuf t rest+		return ret+	else (bf `BS.append`) `liftM` hlGetRn rehandshake t (n - BS.length bf) -hlGetLine_, hlGetContent_ ::-	(ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g BS.ByteString-hlGetLine_ = ($) <$> checkAppData <*> tGetLine_ rehandshake . tlsHandleS-hlGetContent_ = ($) <$> checkAppData <*> tGetContent_ rehandshake . tlsHandleS+hlGetLine_ :: (ValidateHandle h, CPRG g) =>+	TlsHandleS h g -> TlsM h g BS.ByteString+hlGetLine_ (TlsHandleS t) = do+	bf <- HB.getAdBuf t+	if (10 `BS.elem` bf)+	then do	let (ret, rest) = BS.span (/= 10) bf+		HB.setAdBuf t $ BS.tail rest+		return ret+	else (bf `BS.append`) `liftM` hlGetLineRn rehandshake t -checkAppData :: (ValidateHandle h, CPRG g) => TlsHandleS h g ->-	TlsM h g (ContentType, BS.ByteString) -> TlsM h g BS.ByteString-checkAppData (TlsHandleS t) m = m >>= \cp -> case cp of-	(CTAppData, ad) -> return ad-	(CTAlert, "\SOH\NUL") -> do-		_ <- tlsPut_ (t, undefined) CTAlert "\SOH\NUL"-		E.throwError "TlsHandle.checkAppData: EOF"-		{--	(CTHandshake, hs) -> do-		lift . lift $ hlDebug (tlsHandle t) "low" "renegotiation?"-		lift . lift $ hlDebug (tlsHandle t) "low" . BSC.pack $ show hs-		lift . lift $ hlDebug (tlsHandle t) "low" . BSC.pack .-			show $ (B.decode hs :: Either String Handshake)---		renegotiation t hs-		return ""-		-}-	_ -> do	_ <- tlsPut_ (t, undefined) CTAlert "\2\10"-		E.throwError "TlsHandle.checkAppData: not application data"+hlGetContent_ :: (ValidateHandle h, CPRG g) =>+	TlsHandleS h g -> TlsM h g BS.ByteString+hlGetContent_ (TlsHandleS t) = do+	bf <- HB.getAdBuf t+	if BS.null bf+	then hlGetContentRn rehandshake t+	else do	HB.setAdBuf t ""+		return bf -handshake :: (ValidateHandle h, CPRG g) =>-	[CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] ->-	Maybe X509.CertificateStore -> HandshakeM h g ()-handshake _cssv _crts _mcs = do-	(cssv, crts, mcs) <- HB.getInitSet-	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv-	succeed cs cr cv crts mcs rn+type Version = (Word8, Word8) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()-rehandshake t = do-	oldHandshakeM t "" $ handshake undefined undefined undefined-	return ()+version :: Version+version = (3, 3) -renegotiation ::-	(ValidateHandle h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g ()-renegotiation t hs = do-	let	Right ch = B.decode hs-		(cs, cr, cv, rn) = fromClientHello cipherSuites ch-	oldHandshakeM t hs $ succeed cs cr cv certificateSets Nothing rn-	return ()+filterCS :: [(CertSecretKey, X509.CertificateChain)] ->+	[CipherSuite] -> [CipherSuite]+filterCS crts cs = case find isEcdsa crts of+	Just _ -> cs+	_ -> filter (not . isEcdsaCS) cs+	where+	isEcdsaCS (CipherSuite ECDHE_ECDSA _) = True+	isEcdsaCS _ = False++isEcdsa :: (CertSecretKey, X509.CertificateChain) -> Bool+isEcdsa (EcdsaKey _, _) = True+isEcdsa _ = False

@@ -6,6 +6,7 @@ 	CipherSuite(..), KeyExchange(..), BulkEncryption(..), 	randomGen, setRandomGen, 	getBuf, setBuf, getWBuf, setWBuf,+	getAdBuf, setAdBuf, 	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, 	getKeys, setKeys,@@ -49,6 +50,7 @@ 	so = StateOne { 		sKeys = nullKeys, 		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""),+		radBuffer = "", 		readSN = 0, writeSN = 0, 		rnClientFinished = "", rnServerFinished = "", 		initialSettings = ([], [], Nothing)@@ -63,6 +65,7 @@ 	sKeys :: Keys, 	rBuffer :: (ContentType, BS.ByteString), 	wBuffer :: (ContentType, BS.ByteString),+	radBuffer :: BS.ByteString, 	readSN :: Word64, 	writeSN :: Word64, 	rnClientFinished :: BS.ByteString,@@ -148,6 +151,12 @@  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 =

@@ -9,7 +9,7 @@ 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, 		setKeys, 		handshakeHash, finishedHash,-	hlPut_, hlDebug_, hlClose_, tGetLine, tGetContent,+	hlPut_, hlDebug_, hlClose_, tGetLine, tGetLine_, tGetContent, 	getClientFinishedT, setClientFinishedT, 	getServerFinishedT, setServerFinishedT, @@ -17,12 +17,16 @@ 	InitialSettings,  	resetSequenceNumber,+	tlsGet_,+	flushAppData,++	getAdBufT, setAdBufT, 	) where  import Prelude hiding (read)  import Control.Arrow (second)-import Control.Monad (liftM, when, unless)+import Control.Monad (liftM, ap, when, unless) import "monads-tf" Control.Monad.State (get, put, lift) import "monads-tf" Control.Monad.Error (throwError, catchError) import "monads-tf" Control.Monad.Error.Class (strMsg)@@ -37,13 +41,15 @@  import Network.PeyoTLS.TlsMonad ( 	TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug,-		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf,+		withRandom, randomByteString,+		getBuf, setBuf, getWBuf, setWBuf,+		getAdBuf, setAdBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn, 		resetReadSn, resetWriteSn, 		getCipherSuiteSt, setCipherSuiteSt, 		flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, 	Alert(..), AlertLevel(..), AlertDesc(..),-	ContentType(..), CipherSuite(..), KeyExchange(..), BulkEncryption(..),+	ContentType(..), CipherSuite(..), BulkEncryption(..), 	PartnerId, newPartnerId, Keys(..), 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished,@@ -84,22 +90,43 @@ 		setBuf (clientId t) (ct', bf) 		return ct' -tlsGet :: (HandleLike h, CPRG g) => HandleHash h g ->+flushAppData :: (HandleLike h, CPRG g) =>+	TlsHandle h g -> TlsM h g (BS.ByteString, Bool)+flushAppData t = do+	ct <- getContentType t+	case ct of+		CTAppData -> do+			(_, ad) <- tGetContent t+			(bs, b) <- flushAppData t+			return (ad `BS.append` bs, b)+--			liftM (BS.append . snd) (tGetContent t) `ap` flushAppData t+		CTAlert -> do+			((_, a), _) <- tlsGet True (t, undefined) 2+			case a of+				"\1\0" -> return ("", False)+				_ -> throwError "flushAppData"+		_ -> return ("", True)++tlsGet :: (HandleLike h, CPRG g) => Bool -> HandleHash h g -> 	Int -> TlsM h g ((ContentType, BS.ByteString), HandleHash h g)-tlsGet hh@(t, _) n = do+tlsGet b hh@(t, _) n = do 	r@(ct, bs) <- buffered t n-	(r ,) `liftM` case ct of-		CTHandshake -> updateHash hh bs+	(r ,) `liftM` case (ct, b, bs) of+		(CTHandshake, _, "\0\0\0\0") -> return hh+		(CTHandshake, True, _) -> updateHash hh bs 		_ -> return hh +tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	HandleHash h g -> Int ->+	TlsM h g ((ContentType, BS.ByteString), HandleHash h g)+tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n+ buffered :: (HandleLike h, CPRG g) => 	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered t n = do 	(ct, b) <- getBuf $ clientId t; let rl = n - BS.length b 	if rl <= 0-	then do	let (ret, b') = BS.splitAt n b-		setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')-		return (ct, ret)+	then splitRetBuf t n ct b 	else do	(ct', b') <- getWholeWithCt t 		unless (ct' == ct) . throwError . strMsg $ 			"Content Type confliction\n" ++@@ -110,6 +137,30 @@ 		setBuf (clientId t) (ct', b') 		second (b `BS.append`) `liftM` buffered t rl +buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered_ rn t n = do+	ct0 <- getContentType t+	case ct0 of+		CTHandshake -> rn t >> buffered_ rn t n+		_ -> do	(ct, b) <- getBuf $ clientId t; let rl = n - BS.length b+			if rl <= 0+			then splitRetBuf t n ct b+			else do (ct', b') <- getWholeWithCt t+				unless (ct' == ct) . throwError . strMsg $+					"Content Type confliction\n"+				when (BS.null b') $ throwError "buffered: No data"+				setBuf (clientId t) (ct', b')+				second (b `BS.append`) `liftM` buffered_ rn t rl++splitRetBuf :: HandleLike h =>+	TlsHandle h g -> Int -> ContentType -> BS.ByteString ->+	TlsM h g (ContentType, BS.ByteString)+splitRetBuf t n ct b = do+	let (ret, b') = BS.splitAt n b+	setBuf (clientId t) $ if BS.null b' then (CTNull, "") else (ct, b')+	return (ct, ret)+ getWholeWithCt :: (HandleLike h, CPRG g) => 	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) getWholeWithCt t = do@@ -119,8 +170,8 @@ 	e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2 	when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null" 	p <- decrypt t ct e-	thlDebug (tlsHandle t) "high" . BSC.pack . (++ ": ") $ show ct-	thlDebug (tlsHandle t) "high" . BSC.pack . (++  "\n") . show $ BS.head p+	thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct+	thlDebug (tlsHandle t) "medium" . BSC.pack . (++  "\n") . show $ BS.head p 	thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p 	return (ct, p) @@ -152,17 +203,17 @@ 	either (throwError . strMsg) return $ 		CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e -tlsPut :: (HandleLike h, CPRG g) =>+tlsPut :: (HandleLike h, CPRG g) => Bool -> 	HandleHash h g -> ContentType -> BS.ByteString -> TlsM h g (HandleHash h g)-tlsPut hh@(t, _) ct p = do+tlsPut b hh@(t, _) ct p = do 	(bct, bp) <- getWBuf $ clientId t 	case ct of 		CTCCSpec -> flush t >> setWBuf (clientId t) (ct, p) >> flush t 		_	| bct /= CTNull && ct /= bct -> 				flush t >> setWBuf (clientId t) (ct, p) 			| otherwise -> setWBuf (clientId t) (ct, bp `BS.append` p)-	case ct of-		CTHandshake -> updateHash hh p+	case (ct, b) of+		(CTHandshake, True) -> updateHash hh p 		_ -> return hh  flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()@@ -212,10 +263,9 @@ 	return sn  resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g ()-resetSequenceNumber t rw = do-	case rw of-		Read -> resetReadSn $ clientId t-		Write -> resetWriteSn $ clientId t+resetSequenceNumber t rw = case rw of+	Read -> resetReadSn $ clientId t+	Write -> resetWriteSn $ clientId t  generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite -> 	BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys@@ -265,14 +315,14 @@ 	return $ CT.finishedHash (partner == Client) ms sha256  hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g ()-hlPut_ = ((>> return ()) .) . flip tlsPut CTAppData . (, undefined)+hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined)  hlDebug_ :: HandleLike h => 	TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g () hlDebug_ t l = lift . lift . hlDebug (tlsHandle t) l  hlClose_ :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()-hlClose_ t = tlsPut (t, undefined) CTAlert "\SOH\NUL" >>+hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> 	flush t >> thlClose (tlsHandle t)  tGetLine :: (HandleLike h, CPRG g) =>@@ -285,6 +335,22 @@ 			setBuf (clientId t) cp 			second (bp `BS.append`) `liftM` tGetLine t +tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetLine_ rn t = do+	ct <- getContentType t+	case ct of+		CTHandshake -> rn t >> tGetLine_ rn t+		_ -> do	(bct, bp) <- getBuf $ clientId t+			case splitLine bp of+				Just (l, ls) -> do+					setBuf (clientId t) (bct, ls)+					return (bct, l)+				_ -> do	cp <- getWholeWithCt t+					setBuf (clientId t) cp+					second (bp `BS.append`) `liftM`+						tGetLine_ rn t+ splitLine :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) splitLine bs = case ('\r' `BSC.elem` bs, '\n' `BSC.elem` bs) of 	(True, _) -> let@@ -320,3 +386,9 @@  setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g () setInitSetT = setInitSet . clientId++getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+getAdBufT = getAdBuf . clientId++setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()+setAdBufT = setAdBuf . clientId

@@ -3,7 +3,9 @@ module Network.PeyoTLS.TlsMonad ( 	TlsM, evalTlsM, S.initState, 		thlGet, thlPut, thlClose, thlDebug, thlError,-		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf,+		withRandom, randomByteString,+		getBuf, setBuf, getWBuf, setWBuf,+		getAdBuf, setAdBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn, 		resetReadSn, resetWriteSn, 		getCipherSuiteSt, setCipherSuiteSt,@@ -34,6 +36,7 @@ 	CipherSuite(..), KeyExchange(..), BulkEncryption(..), 	randomGen, setRandomGen, 	setBuf, getBuf, setWBuf, getWBuf,+	setAdBuf, getAdBuf, 	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite, 	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,@@ -53,6 +56,12 @@ getBuf, getWBuf ::  HandleLike h => 	S.PartnerId -> TlsM h g (S.ContentType, BS.ByteString) getBuf = gets . S.getBuf; getWBuf = gets . S.getWBuf++getAdBuf :: HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getAdBuf = gets . S.getAdBuf++setAdBuf :: HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setAdBuf = (modify .) . S.setAdBuf  setBuf, setWBuf :: HandleLike h => 	S.PartnerId -> (S.ContentType, BS.ByteString) -> TlsM h g ()

@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports #-}++import Control.Applicative+import Control.Concurrent+import "crypto-random" Crypto.Random++import CIRenegoClient+import Data.HandleLike++import Control.Concurrent.STM+import qualified Data.ByteString as BS+import System.IO+import CommandLine+import System.Environment++import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509++import CIRenegoServer+import System.Random++cipherSuites :: [CipherSuite]+cipherSuites = [+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA,+	CipherSuite DHE_RSA AES_128_CBC_SHA256,+	CipherSuite DHE_RSA AES_128_CBC_SHA,+	CipherSuite RSA AES_128_CBC_SHA256,+	CipherSuite RSA AES_128_CBC_SHA+ ]++randomFrom :: [a] -> IO [a]+randomFrom [] = return []+randomFrom (x : xs) = do+	b <- randomIO+	(if b then (x :) else id) <$> randomFrom xs++main :: IO ()+main = do+	b <- randomIO+	(if b then runRsa "critical" else ecdsa "critical") =<< randomFrom cipherSuites++runRsa :: Priority -> [CipherSuite] -> IO ()+runRsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFiles+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++ecdsa :: Priority -> [CipherSuite] -> IO ()+ecdsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFilesEcdsa+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++srv :: ChanHandle -> [CipherSuite] -> IO ()+srv sw cs = do+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	(_prt, _cs, rsa, ec, mcs, _td) <- readOptions =<< getArgs+	server g sw cs rsa ec mcs++readFiles :: IO (CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFiles = (,,)+	<$> readPathKey "certs/yoshikuni.sample_key"+	<*> readPathCertificateChain "certs/yoshikuni.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++readFilesEcdsa :: IO+	(CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFilesEcdsa = (,,)+	<$> readPathKey "certs/client_ecdsa.sample_key"+	<*> readPathCertificateChain "certs/client_ecdsa.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++data ChanHandle = ChanHandle (TChan BS.ByteString) (TChan BS.ByteString) Priority++instance HandleLike ChanHandle where+	type HandleMonad ChanHandle = IO+	hlPut (ChanHandle _ w _) = atomically . writeTChan w+	hlGet h@(ChanHandle r _ _) n = do+		(b, l, bs) <- atomically $ do+			bs <- readTChan r+			let l = BS.length bs+			if l < n+				then return (True, l, bs)+				else do	let (x, y) = BS.splitAt n bs+					unGetTChan r y+					return (False, l, x)+		if b	then (bs `BS.append`) <$> hlGet h (n - l)+			else return bs+	hlDebug (ChanHandle _ _ p) dl+		| dl >= p = BS.putStr+		| otherwise = const $ return ()+	hlClose _ = return ()++instance ValidateHandle ChanHandle where+	validate _ = validate (undefined :: Handle)++getPair :: Priority -> IO (ChanHandle, ChanHandle)+getPair p = do+	c1 <- newTChanIO+	c2 <- newTChanIO+	return (ChanHandle c1 c2 p, ChanHandle c2 c1 p)

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports #-}++import Control.Applicative+import Control.Monad+import Control.Concurrent+import "crypto-random" Crypto.Random++import TestClient+import Data.HandleLike++import Control.Concurrent.STM+import qualified Data.ByteString as BS+import System.IO+import CommandLine+import System.Environment++import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509++import TestServer+import System.Random++cipherSuites :: [CipherSuite]+cipherSuites = [+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA,+	CipherSuite DHE_RSA AES_128_CBC_SHA256,+	CipherSuite DHE_RSA AES_128_CBC_SHA,+	CipherSuite RSA AES_128_CBC_SHA256,+	CipherSuite RSA AES_128_CBC_SHA+ ]++randomFrom :: [a] -> IO [a]+randomFrom [] = return []+randomFrom (x : xs) = do+	b <- randomIO+	(if b then (x :) else id) <$> randomFrom xs++main :: IO ()+main = do+	b <- randomIO+	forM_ ["low" .. "critical"] $ \p -> do+		print p+		(if b then runRsa p else ecdsa p) =<< randomFrom cipherSuites++runRsa :: Priority -> [CipherSuite] -> IO ()+runRsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFiles+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++ecdsa :: Priority -> [CipherSuite] -> IO ()+ecdsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFilesEcdsa+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++srv :: ChanHandle -> [CipherSuite] -> IO ()+srv sw cs = do+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	(_prt, _cs, rsa, ec, mcs, _td) <- readOptions =<< getArgs+	server g sw cs rsa ec mcs++readFiles :: IO (CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFiles = (,,)+	<$> readPathKey "certs/yoshikuni.sample_key"+	<*> readPathCertificateChain "certs/yoshikuni.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++readFilesEcdsa :: IO+	(CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFilesEcdsa = (,,)+	<$> readPathKey "certs/client_ecdsa.sample_key"+	<*> readPathCertificateChain "certs/client_ecdsa.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++data ChanHandle = ChanHandle (TChan BS.ByteString) (TChan BS.ByteString) Priority++instance HandleLike ChanHandle where+	type HandleMonad ChanHandle = IO+	hlPut (ChanHandle _ w _) = atomically . writeTChan w+	hlGet h@(ChanHandle r _ _) n = do+		(b, l, bs) <- atomically $ do+			bs <- readTChan r+			let l = BS.length bs+			if l < n+				then return (True, l, bs)+				else do	let (x, y) = BS.splitAt n bs+					unGetTChan r y+					return (False, l, x)+		if b	then (bs `BS.append`) <$> hlGet h (n - l)+			else return bs+	hlDebug (ChanHandle _ _ p) dl+		| dl >= p = BS.putStr+		| otherwise = const $ return ()+	hlClose _ = return ()++instance ValidateHandle ChanHandle where+	validate _ = validate (undefined :: Handle)++getPair :: Priority -> IO (ChanHandle, ChanHandle)+getPair p = do+	c1 <- newTChanIO+	c2 <- newTChanIO+	return (ChanHandle c1 c2 p, ChanHandle c2 c1 p)

@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports #-}++import Control.Applicative+import Control.Concurrent+import "crypto-random" Crypto.Random++import RenegClient+import Data.HandleLike++import Control.Concurrent.STM+import qualified Data.ByteString as BS+import System.IO+import CommandLine+import System.Environment++import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509++import RenegServer+import System.Random++cipherSuites :: [CipherSuite]+cipherSuites = [+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_ECDSA AES_128_CBC_SHA,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA256,+	CipherSuite ECDHE_RSA AES_128_CBC_SHA,+	CipherSuite DHE_RSA AES_128_CBC_SHA256,+	CipherSuite DHE_RSA AES_128_CBC_SHA,+	CipherSuite RSA AES_128_CBC_SHA256,+	CipherSuite RSA AES_128_CBC_SHA+ ]++randomFrom :: [a] -> IO [a]+randomFrom [] = return []+randomFrom (x : xs) = do+	b <- randomIO+	(if b then (x :) else id) <$> randomFrom xs++main :: IO ()+main = do+	b <- randomIO+	(if b then runRsa "low" else ecdsa "low") =<< randomFrom cipherSuites++runRsa :: Priority -> [CipherSuite] -> IO ()+runRsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFiles+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++ecdsa :: Priority -> [CipherSuite] -> IO ()+ecdsa p cs = do+	(cw, sw) <- getPair p+	_ <- forkIO $ srv sw cs+	(rsk, rcc, crtS) <- readFilesEcdsa+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	client g cw [(rsk, rcc)] crtS++srv :: ChanHandle -> [CipherSuite] -> IO ()+srv sw cs = do+	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	(_prt, _cs, rsa, ec, mcs, _td) <- readOptions =<< getArgs+	server g sw cs rsa ec mcs++readFiles :: IO (CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFiles = (,,)+	<$> readPathKey "certs/yoshikuni.sample_key"+	<*> readPathCertificateChain "certs/yoshikuni.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++readFilesEcdsa :: IO+	(CertSecretKey, X509.CertificateChain, X509.CertificateStore)+readFilesEcdsa = (,,)+	<$> readPathKey "certs/client_ecdsa.sample_key"+	<*> readPathCertificateChain "certs/client_ecdsa.sample_crt"+	<*> readPathCertificateStore ["certs/cacert.pem"]++data ChanHandle = ChanHandle (TChan BS.ByteString) (TChan BS.ByteString) Priority++instance HandleLike ChanHandle where+	type HandleMonad ChanHandle = IO+	hlPut (ChanHandle _ w _) = atomically . writeTChan w+	hlGet h@(ChanHandle r _ _) n = do+		(b, l, bs) <- atomically $ do+			bs <- readTChan r+			let l = BS.length bs+			if l < n+				then return (True, l, bs)+				else do	let (x, y) = BS.splitAt n bs+					unGetTChan r y+					return (False, l, x)+		if b	then (bs `BS.append`) <$> hlGet h (n - l)+			else return bs+	hlDebug (ChanHandle _ _ p) dl+		| dl >= p = BS.putStr+		| otherwise = const $ return ()+	hlClose _ = return ()++instance ValidateHandle ChanHandle where+	validate _ = validate (undefined :: Handle)++getPair :: Priority -> IO (ChanHandle, ChanHandle)+getPair p = do+	c1 <- newTChanIO+	c2 <- newTChanIO+	return (ChanHandle c1 c2 p, ChanHandle c2 c1 p)