peyotls 0.0.0.13 → 0.0.0.14

raw patch · 9 files changed

+398/−78 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/debugServer.hs +3/−2
• peyotls.cabal +11/−3
• src/Network/PeyoTLS/HandshakeBase.hs +65/−6
• src/Network/PeyoTLS/HandshakeMonad.hs +72/−5
• src/Network/PeyoTLS/HandshakeType.hs +1/−1
• src/Network/PeyoTLS/Server.hs +133/−14
• src/Network/PeyoTLS/State.hs +42/−5
• src/Network/PeyoTLS/TlsHandle.hs +47/−39
• src/Network/PeyoTLS/TlsMonad.hs +24/−3

@@ -25,9 +25,10 @@ 		(h, _, _) <- liftIO $ accept soc 		g <- StateT $ return . cprgFork 		liftIO . forkIO . (`run` g) $ do-			p <- open (DebugHandle h $ Just "medium") ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+			p <- open (DebugHandle h $ Just "low") ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)] 				Nothing-			doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+--			doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+			hlGetContent p >>= liftIO . BSC.putStrLn 			hlPut p $ BS.concat [ 				"HTTP/1.1 200 OK\r\n", 				"Transfer-Encoding: chunked\r\n",

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.13+version:	0.0.0.14 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -39,11 +39,19 @@     .     * 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+    .     Currently not implemente the following features.     .     * session resumption (RFC 5077)     .-    * renegotiation (RFC 5746)+    * renegotiation (RFC 5746): partially     .     Server sample     .@@ -273,7 +281,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.13+    tag:	peyotls-0.0.0.14  library     hs-source-dirs:	src

@@ -4,7 +4,7 @@ module Network.PeyoTLS.HandshakeBase ( Extension(..), 	PeyotlsM, PeyotlsHandle, 	debug, generateKs, blindSign, CertSecretKey(..),-	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM,+	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.oldHandshakeM, 	HM.withRandom, HM.randomByteString, 	HM.TlsHandle, HM.names, 		readHandshake, getChangeCipherSpec,@@ -23,12 +23,24 @@ 		HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite, 	DigitallySigned(..), HM.handshakeHash, HM.flushCipherSuite, 	HM.Side(..), HM.RW(..), finishedHash,-	DhParam(..), dh3072Modp, secp256r1, HM.throwError ) where+	DhParam(..), dh3072Modp, secp256r1, HM.throwError,+	HM.getClientFinished, HM.setClientFinished,+	HM.getServerFinished, HM.setServerFinished,+	Finished(..),+	HM.ContentType(CTAlert, CTHandshake, CTAppData),+	HM.tlsPut_,+	Handshake(..),+	HM.tlsHandle,+	HM.tGetContent_,+	HM.tlsGet_,+	HM.tGetLine_,+	) where  import Control.Applicative import Control.Arrow (first) import Control.Monad (liftM, ap) import "monads-tf" Control.Monad.State (gets, lift)+import qualified "monads-tf" Control.Monad.Error as E import Data.Word (Word8) import Data.HandleLike (HandleLike(..)) import System.IO (Handle)@@ -52,7 +64,7 @@ import qualified Crypto.Types.PubKey.ECDSA as ECDSA  import Network.PeyoTLS.HandshakeType ( Extension(..),-	Handshake, HandshakeItem(..),+	Handshake(..), HandshakeItem(..), 	ClientHello(..), ServerHello(..), SessionId(..), 		CipherSuite(..), KeyExchange(..), BulkEncryption(..), 		CompressionMethod(..),@@ -62,7 +74,8 @@ 	ServerHelloDone(..), ClientKeyExchange(..), Epms(..), 	DigitallySigned(..), Finished(..) ) import qualified Network.PeyoTLS.HandshakeMonad as HM (-	TlsM, run, HandshakeM, execHandshakeM, withRandom, randomByteString,+	TlsM, run, HandshakeM, execHandshakeM, oldHandshakeM,+	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate, 	TlsHandle(..), ContentType(..), 		names,@@ -70,7 +83,15 @@ 		tlsGetContentType, tlsGet, tlsPut, 		generateKeys, encryptRsa, decryptRsa, rsaPadding, 	Alert(..), AlertLevel(..), AlertDesc(..),-	Side(..), RW(..), handshakeHash, finishedHash, throwError )+	Side(..), RW(..), handshakeHash, finishedHash, throwError,+	hlPut_, tGetLine, tGetContent, tlsGet_, tlsPut_,+	tGetLine_, tGetContent_, tlsGet__,+--	hlGet_, hlGetLine_, hlGetContent_,+	hlDebug_, hlClose_,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,+	resetSequenceNumber,+	) import Network.PeyoTLS.Ecdsa (blindSign, generateKs)  import Network.PeyoTLS.CertSecretKey@@ -121,9 +142,12 @@ 			"HandshakeBase.getChangeCipherSpec: " ++ 			"not change cipher spec: " ++ 			show cnt+	HM.resetSequenceNumber HM.Read  putChangeCipherSpec :: (HandleLike h, CPRG g) => HM.HandshakeM h g ()-putChangeCipherSpec = uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec+putChangeCipherSpec = do+	uncurry HM.tlsPut . encodeContent $ CCCSpec ChangeCipherSpec+	HM.resetSequenceNumber HM.Write  data Content = CCCSpec ChangeCipherSpec | CAlert Word8 Word8 | CHandshake Handshake 	deriving Show@@ -245,3 +269,38 @@  finishedHash :: (HandleLike h, CPRG g) => HM.Side -> HM.HandshakeM h g Finished finishedHash = (Finished `liftM`) . HM.finishedHash++instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where+	type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g+	type DebugLevel (HM.TlsHandle h g) = DebugLevel h+	hlPut = HM.hlPut_+	hlGet = hlGet_+	hlGetLine = hlGetLine_+	hlGetContent = hlGetContent_+	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+	(HM.CTAppData, ad) -> return ad+	(HM.CTAlert, "\SOH\NUL") -> do+		_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\SOH\NUL"+		E.throwError "TlsHandle.checkAppData: EOF"+	(HM.CTHandshake, hs) -> do+		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?"+		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)+		return ""+	_ -> do	_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10"+		E.throwError "TlsHandle.checkAppData: not application data"

@@ -1,15 +1,26 @@-{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports, TypeFamilies #-}  module Network.PeyoTLS.HandshakeMonad (-	TH.TlsM, TH.run, HandshakeM, execHandshakeM, withRandom, randomByteString,+	TH.TlsM, TH.run, HandshakeM, execHandshakeM, oldHandshakeM,+	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate, 	TH.TlsHandle(..), TH.ContentType(..), 		setCipherSuite, flushCipherSuite, debugCipherSuite, 		tlsGetContentType, tlsGet, tlsPut, 		generateKeys, encryptRsa, decryptRsa, rsaPadding, 	TH.Alert(..), TH.AlertLevel(..), TH.AlertDesc(..),-	TH.Side(..), TH.RW(..), handshakeHash, finishedHash, throwError ) where+	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,+	) where+ import Prelude hiding (read)  import Control.Applicative@@ -40,8 +51,51 @@ 		newHandle, getContentType, tlsGet, tlsPut, generateKeys, 		debugCipherSuite, 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys,-	Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..) )+	Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..),+	hlPut_, hlDebug_, hlClose_, tGetContent, tGetLine,+	getClientFinishedT, setClientFinishedT,+	getServerFinishedT, setServerFinishedT, +	resetSequenceNumber,+	)++resetSequenceNumber :: HandleLike h => TH.RW -> HandshakeM h g ()+resetSequenceNumber rw = gets fst >>= lift . flip TH.resetSequenceNumber rw++tlsGet_ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g -> TH.TlsM h g ()) ->+	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))+tlsGet_ 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__ :: (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++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++tGetContent_ rn t = do+	ct <- TH.getContentType t+	case ct of+		TH.CTHandshake -> rn t >> tGetContent_ rn t+		_ -> TH.tGetContent t++tlsPut_ :: (HandleLike h, CPRG g) =>+	(TH.TlsHandle h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle h g, SHA256.Ctx)+tlsPut_ = TH.tlsPut+ throwError :: HandleLike h => 	TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a throwError al ad m = E.throwError $ TH.Alert al ad m@@ -53,6 +107,10 @@ 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)+ withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a withRandom = lift . TH.withRandom @@ -120,7 +178,7 @@ generateKeys p (cr, sr) pms = do 	t <- gets fst 	cs <- lift $ TH.getCipherSuiteSt (TH.clientId t)-	k <- lift $ TH.generateKeys p cs cr sr pms+	k <- lift $ TH.generateKeys t p cs cr sr pms 	lift $ TH.setKeys (TH.clientId t) k --	modify . first $ const t { TH.keys = k } @@ -144,3 +202,12 @@  finishedHash :: (HandleLike h, CPRG g) => TH.Side -> HandshakeM h g BS.ByteString finishedHash p = get >>= lift . flip TH.finishedHash p++getClientFinished, getServerFinished :: HandleLike h => HandshakeM h g BS.ByteString+getClientFinished = gets fst >>= lift . TH.getClientFinishedT+getServerFinished = gets fst >>= lift . TH.getServerFinishedT++setClientFinished, setServerFinished ::+	HandleLike h => BS.ByteString -> HandshakeM h g ()+setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf+setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf

@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Network.PeyoTLS.HandshakeType ( Extension(..),-	Handshake, HandshakeItem(..),+	Handshake(..), HandshakeItem(..), 	ClientHello(..), ServerHello(..), SessionId(..), 		CipherSuite(..), KeyExchange(..), BulkEncryption(..), 		CompressionMethod(..),

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, FlexibleContexts,-	PackageImports #-}+	PackageImports, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Network.PeyoTLS.Server (@@ -9,8 +9,9 @@ 	TlsM, TlsHandle, 	ValidateHandle(..), CertSecretKey ) where +import Control.Applicative import Control.Monad (unless, liftM, ap)-import "monads-tf" Control.Monad.Error (catchError)+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 Data.List (find)@@ -19,6 +20,7 @@ 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@@ -29,10 +31,13 @@ import qualified Crypto.Types.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Network.PeyoTLS.HandshakeBase as HB+ import Network.PeyoTLS.HandshakeBase ( debug, Extension(..), 	PeyotlsM, PeyotlsHandle,-	TlsM, run, HandshakeM, execHandshakeM, withRandom, randomByteString,-	TlsHandle, names,+	TlsM, run, HandshakeM, execHandshakeM, oldHandshakeM,+	withRandom, randomByteString,+	TlsHandle, 		readHandshake, getChangeCipherSpec, 		writeHandshake, putChangeCipherSpec, 	ValidateHandle(..), handshakeValidate,@@ -48,8 +53,32 @@ 	DigitallySigned(..), handshakeHash, flushCipherSuite, 	Side(..), RW(..), finishedHash, 	DhParam(..), dh3072Modp, secp256r1, throwError,-	CertSecretKey(..) )+	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"+	]++certificateSets :: [(CertSecretKey, X509.CertificateChain)]+certificateSets = unsafePerformIO $ do+	k <- readKey "rsa2048.sample_key"+	c <- readCertificateChain "rsa2048.sample_crt"+	return [(k, c)]++names :: TlsHandleS h g -> [String]+names = HB.names . tlsHandleS+ type Version = (Word8, Word8)  version :: Version@@ -76,9 +105,15 @@ open :: (ValidateHandle h, CPRG g) => h -> 	[CipherSuite] -> 	[(CertSecretKey, X509.CertificateChain)] ->-	Maybe X509.CertificateStore -> TlsM h g (TlsHandle h g)-open h cssv crts mcs = execHandshakeM h $ do-	(cs@(CipherSuite ke be), cr, cv, rn) <- clientHello $ filterCS crts cssv+	Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g)+open h cssv crts mcs = (TlsHandleS `liftM`) . execHandshakeM h $ do+	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv+	succeed cs cr cv crts mcs rn++succeed :: (ValidateHandle h, CPRG g) => CipherSuite -> BS.ByteString ->+	Version -> [(CertSecretKey, X509.CertificateChain)] ->+	Maybe X509.CertificateStore -> Bool -> HandshakeM h g ()+succeed cs@(CipherSuite ke be) cr cv crts mcs rn = do 	sr <- serverHello cs rcc ecc rn 	setCipherSuite cs 	ha <- case be of@@ -95,12 +130,20 @@ 		_ -> \_ _ -> E.throwError 			"TlsServer.open: not implemented key exchange type" 	maybe (return ()) certificateVerify mpk+	debug "low" ("before getChangeCipherSpec" :: String) 	getChangeCipherSpec >> flushCipherSuite Read-	fok <- (==) `liftM` finishedHash Client `ap` readHandshake-	unless fok $ throwError ALFatal ADDecryptError+	cf@(Finished cfb) <- finishedHash Client+	debug "low" ("client finished" :: String)+	debug "low" cf+	rcf <- readHandshake+	debug "low" rcf+	unless (cf == rcf) $ throwError ALFatal ADDecryptError 		"TlsServer.open: wrong finished hash"+	setClientFinished cfb 	putChangeCipherSpec >> flushCipherSuite Write-	writeHandshake =<< finishedHash Server+	sf@(Finished sfb) <- finishedHash Server+	setServerFinished sfb+	writeHandshake sf 	where 	Just (RsaKey rsk, rcc) = find isRsa crts 	Just (EcdsaKey esk, ecc) = find isEcdsa crts@@ -125,13 +168,22 @@ 		`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"+ clientHello :: (HandleLike h, CPRG g) => 	[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool) clientHello cssv = do-	ch@(ClientHello cv cr _sid cscl cms e) <- readHandshake+	ch@(ClientHello cv cr _sid cscl cms _e) <- readHandshake 	debug "medium" ch --	debug "medium" e-	let rn = maybe False (ERenegoInfo "" `elem`) e+--	let rn = maybe False (ERenegoInfo "" `elem`) e+	let rn = True --	debug "medium" rn 	chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn) 	where@@ -156,9 +208,11 @@ 	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 ""]+			then Just [ERenegoInfo $ cf `BS.append` sf] 			else Nothing 	writeHandshake $ case ke of ECDHE_ECDSA -> ecc; _ -> rcc 	return sr@@ -206,6 +260,8 @@ 	Version -> (BS.ByteString, BS.ByteString) -> HandshakeM h g () rsaClientKeyExchange sk (cvj, cvn) rs = do 	Epms epms <- readHandshake+	debug "low" ("EPMS" :: String)+	debug "low" epms 	generateKeys Server rs =<< mkpms epms `catchError` const 		((BS.cons cvj . BS.cons cvn) `liftM` randomByteString 46) 	where@@ -216,6 +272,8 @@ 			[pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $ 				E.throwError "mkpms: version" 			_ -> E.throwError "mkpms: never occur"+		debug "low" ("PMS" :: String)+		debug "low" pms 		return pms  dhClientKeyExchange :: (HandleLike h, CPRG g, DhParam dp, B.Bytable (Public dp),@@ -259,3 +317,64 @@ 		(either error id $ B.decode y) certificateVerify p = throwError ALFatal ADUnsupportedCertificate $ 	"TlsServer.certificateVerify: not implement: " ++ show p++newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g }++instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where+	type HandleMonad (TlsHandleS h g) = HandleMonad (TlsHandle h g)+	type DebugLevel (TlsHandleS h g) = DebugLevel (TlsHandle h g)+	hlPut (TlsHandleS t) = hlPut t+	hlGet = hlGet_+	hlGetLine = hlGetLine_+	hlGetContent = hlGetContent_+	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++hlGetLine_, hlGetContent_ ::+	(ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g BS.ByteString+hlGetLine_ = ($) <$> checkAppData <*> tGetLine_ rehandshake . tlsHandleS+hlGetContent_ = ($) <$> checkAppData <*> tGetContent_ rehandshake . tlsHandleS++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"++handshake :: (ValidateHandle h, CPRG g) =>+	[CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] ->+	Maybe X509.CertificateStore -> HandshakeM h g ()+handshake cssv crts mcs = do+	(cs, cr, cv, rn) <- clientHello $ filterCS crts cssv+	succeed cs cr cv crts mcs rn++rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+rehandshake t = do+	oldHandshakeM t "" $ handshake cipherSuites certificateSets Nothing+	return ()++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 ()

@@ -6,9 +6,11 @@ 	CipherSuite(..), KeyExchange(..), BulkEncryption(..), 	randomGen, setRandomGen, 	getBuf, setBuf, getWBuf, setWBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN,+	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, 	getKeys, setKeys,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished, ) where  import "monads-tf" Control.Monad.Error.Class (Error(strMsg))@@ -40,7 +42,9 @@ 	so = StateOne { 		sKeys = nullKeys, 		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""),-		readSN = 0, writeSN = 0 }+		readSN = 0, writeSN = 0,+		rnClientFinished = "", rnServerFinished = ""+		} 	sos = states s  data StateOne g = StateOne {@@ -48,7 +52,10 @@ 	rBuffer :: (ContentType, BS.ByteString), 	wBuffer :: (ContentType, BS.ByteString), 	readSN :: Word64,-	writeSN :: Word64 }+	writeSN :: Word64,+	rnClientFinished :: BS.ByteString,+	rnServerFinished :: BS.ByteString+	}  getState :: PartnerId -> HandshakeState h g -> StateOne g getState i = fromJust' "getState" . lookup i . states@@ -63,6 +70,10 @@ 	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)@@ -73,6 +84,8 @@ 	kReadCS = CipherSuite KE_NULL BE_NULL, 	kWriteCS = CipherSuite KE_NULL BE_NULL, 	kMasterSecret = "",+	kCachedReadMacKey = "", kCachedWriteMacKey = "",+	kCachedReadKey = "", kCachedWriteKey = "", 	kReadMacKey = "", kWriteMacKey = "", kReadKey = "", kWriteKey = "" }  data ContentType@@ -135,13 +148,33 @@ setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g) setKeys i = modifyState i . \k st -> st { sKeys = k } +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) } }+	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) } }+	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@@ -156,6 +189,10 @@ 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 

@@ -8,11 +8,16 @@ 		debugCipherSuite, 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, 		setKeys,-		handshakeHash, finishedHash ) where+		handshakeHash, finishedHash,+	hlPut_, hlDebug_, hlClose_, tGetLine, tGetContent,+	getClientFinishedT, setClientFinishedT,+	getServerFinishedT, setServerFinishedT, +	resetSequenceNumber,+	) where+ import Prelude hiding (read) -import Control.Applicative ((<$>), (<*>)) import Control.Arrow (second) import Control.Monad (liftM, when, unless) import "monads-tf" Control.Monad.State (get, put, lift)@@ -31,11 +36,15 @@ 	TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug, 		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn,+		resetReadSn, resetWriteSn, 		getCipherSuiteSt, setCipherSuiteSt, 		flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, 	Alert(..), AlertLevel(..), AlertDesc(..), 	ContentType(..), CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	PartnerId, newPartnerId, Keys(..))+	PartnerId, newPartnerId, Keys(..),+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,+	) import qualified Network.PeyoTLS.CryptoTools as CT ( 	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) @@ -197,31 +206,34 @@ 			Write -> succWriteSn $ clientId t 	return sn -generateKeys :: HandleLike h => Side -> CipherSuite ->+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++generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite -> 	BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys-generateKeys p cs cr sr pms = do+generateKeys t p cs cr sr pms = do 	let CipherSuite _ be = cs 	kl <- case be of 		AES_128_CBC_SHA -> return 20 		AES_128_CBC_SHA256 -> return 32 		_ -> throwError 			"TlsServer.generateKeys: not implemented bulk encryption"-	let (ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms+	let	(ms, cwmk, swmk, cwk, swk) = CT.makeKeys kl cr sr pms+	k <- getKeys $ clientId t 	return $ case p of-		Client -> Keys {+		Client -> k { 			kCachedCS = cs,-			kReadCS = CipherSuite KE_NULL BE_NULL,-			kWriteCS = CipherSuite KE_NULL BE_NULL, 			kMasterSecret = ms,-			kReadMacKey = swmk, kWriteMacKey = cwmk,-			kReadKey = swk, kWriteKey = cwk }-		Server -> Keys {+			kCachedReadMacKey = swmk, kCachedWriteMacKey = cwmk,+			kCachedReadKey = swk, kCachedWriteKey = cwk }+		Server -> k { 			kCachedCS = cs,-			kReadCS = CipherSuite KE_NULL BE_NULL,-			kWriteCS = CipherSuite KE_NULL BE_NULL, 			kMasterSecret = ms,-			kReadMacKey = cwmk, kWriteMacKey = swmk,-			kReadKey = cwk, kWriteKey = swk }+			kCachedReadMacKey = cwmk, kCachedWriteMacKey = swmk,+			kCachedReadKey = cwk, kCachedWriteKey = swk }  data RW = Read | Write deriving Show @@ -247,17 +259,17 @@ 	sha256 <- handshakeHash (t, ctx) 	return $ CT.finishedHash (partner == Client) ms sha256 -instance (HandleLike h, CPRG g) => HandleLike (TlsHandle h g) where-	type HandleMonad (TlsHandle h g) = TlsM h g-	type DebugLevel (TlsHandle h g) = DebugLevel h-	hlPut = ((>> return ()) .) . flip tlsPut CTAppData . (, undefined)-	hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) . tlsGet . (, undefined)-	hlGetLine = ($) <$> checkAppData <*> tGetLine-	hlGetContent = ($) <$> checkAppData <*> tGetContent-	hlDebug t l = lift . lift . hlDebug (tlsHandle t) l-	hlClose t = tlsPut (t, undefined) CTAlert "\SOH\NUL" >>-		flush t >> thlClose (tlsHandle t)+hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g ()+hlPut_ = ((>> return ()) .) . flip tlsPut 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" >>+	flush t >> thlClose (tlsHandle t)+ tGetLine :: (HandleLike h, CPRG g) => 	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString) tGetLine t = do@@ -288,16 +300,12 @@ 	if BS.null bp then getWholeWithCt t else 		setBuf (clientId t) (CTNull, BS.empty) >> return bcp -checkAppData :: (HandleLike h, CPRG g) => TlsHandle h g ->-	TlsM h g (ContentType, BS.ByteString) -> TlsM h g BS.ByteString-checkAppData t m = m >>= \cp -> case cp of-	(CTAppData, ad) -> return ad-	(CTAlert, "\SOH\NUL") -> do-		_ <- tlsPut (t, undefined) CTAlert "\SOH\NUL"-		throwError "TlsHandle.checkAppData: EOF"-	(CTHandshake, hs) -> do-		lift . lift $ hlDebug (tlsHandle t) "critical" "renegotiation?"-		lift . lift $ hlDebug (tlsHandle t) "critical" . BSC.pack $ show hs-		return ""-	_ -> do	_ <- tlsPut (t, undefined) CTAlert "\2\10"-		throwError "TlsHandle.checkAppData: not application data"+getClientFinishedT, getServerFinishedT ::+	HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+getClientFinishedT = getClientFinished . clientId+getServerFinishedT = getServerFinished . clientId++setClientFinishedT, setServerFinishedT ::+	HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()+setClientFinishedT = setClientFinished . clientId+setServerFinishedT = setServerFinished . clientId

@@ -5,13 +5,18 @@ 		thlGet, thlPut, thlClose, thlDebug, thlError, 		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn,+		resetReadSn, resetWriteSn, 		getCipherSuiteSt, setCipherSuiteSt, 		flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, 	S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), 	S.ContentType(..), 	S.CipherSuite(..), S.KeyExchange(..), S.BulkEncryption(..),-	S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys ) where+	S.PartnerId, S.newPartnerId, S.Keys(..), S.nullKeys, +	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,+	) where+ import Control.Monad (liftM) import "monads-tf" Control.Monad.Trans (lift) import "monads-tf" Control.Monad.State (StateT, evalStateT, gets, modify)@@ -28,9 +33,12 @@ 	CipherSuite(..), KeyExchange(..), BulkEncryption(..), 	randomGen, setRandomGen, 	setBuf, getBuf, setWBuf, getWBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN,+	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite,-	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys)+	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,+	getClientFinished, setClientFinished,+	getServerFinished, setServerFinished,+	)  type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h)) @@ -52,6 +60,9 @@ succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g () succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN +resetWriteSn, resetReadSn :: HandleLike h => S.PartnerId -> TlsM h g ()+resetWriteSn = modify . S.resetWriteSN; resetReadSn = modify . S.resetReadSN+ getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite getCipherSuiteSt = gets . S.getCipherSuite @@ -63,6 +74,16 @@  getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys getKeys = gets . S.getKeys++getClientFinished, getServerFinished ::+	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString+getClientFinished = gets . S.getClientFinished+getServerFinished = gets . S.getServerFinished++setClientFinished, setServerFinished ::+	HandleLike h => S.PartnerId -> BS.ByteString -> TlsM h g ()+setClientFinished = (modify .) . S.setClientFinished+setServerFinished = (modify .) . S.setServerFinished  flushCipherSuiteRead, flushCipherSuiteWrite :: 	HandleLike h => S.PartnerId -> TlsM h g ()