peyotls 0.1.3.0 → 0.1.4.0

raw patch · 13 files changed

+882/−593 lines, 13 filesdep +monad-controldep +transformers-basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monad-control, transformers-base

API changes (from Hackage documentation)

Files

• peyotls.cabal +8/−4
• src/Network/PeyoTLS/Base.hs +4/−2
• src/Network/PeyoTLS/Client.hs +2/−292
• src/Network/PeyoTLS/Client/Body.hs +318/−0
• src/Network/PeyoTLS/Run.hs +4/−2
• src/Network/PeyoTLS/Run/Crypto.hs +2/−1
• src/Network/PeyoTLS/Run/Handle.hs +4/−2
• src/Network/PeyoTLS/Run/Monad.hs +16/−6
• src/Network/PeyoTLS/Run/State.hs +2/−2
• src/Network/PeyoTLS/Server.hs +3/−282
• src/Network/PeyoTLS/Server/Body.hs +324/−0
• src/Network/PeyoTLS/TChan/Client.hs +119/−0
• src/Network/PeyoTLS/TChan/Server.hs +76/−0

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.1.3.0+version:	0.1.4.0 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -281,13 +281,16 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.1.3.0+    tag:	peyotls-0.1.4.0  library     hs-source-dirs:	src     exposed-modules:-        Network.PeyoTLS.Client, Network.PeyoTLS.Server, Network.PeyoTLS.ReadFile+        Network.PeyoTLS.Client, Network.PeyoTLS.Server,+        Network.PeyoTLS.TChan.Client, Network.PeyoTLS.TChan.Server,+        Network.PeyoTLS.ReadFile     other-modules:+        Network.PeyoTLS.Client.Body, Network.PeyoTLS.Server.Body,         Network.PeyoTLS.Base,         Network.PeyoTLS.Codec,             Network.PeyoTLS.Codec.Hello, Network.PeyoTLS.Codec.Extension,@@ -306,7 +309,8 @@         cryptohash == 0.11.*,         crypto-pubkey == 0.2.*, crypto-pubkey-types == 0.4.*,         cipher-aes == 0.2.*,-        bytable == 0.1.*, handle-like == 0.1.*+        bytable == 0.1.*, handle-like == 0.1.*,+        stm == 2.4.*, transformers-base == 0.4.*, monad-control == 0.3.*     ghc-options:	-Wall     extensions:		PatternGuards, DoAndIfThenElse 

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}  module Network.PeyoTLS.Base (-	PeyotlsM, TlsM, run, SettingsS,+	TlsState(..), State1(..), wFlush, Keys(..),+	PeyotlsM, TlsM, run, run', SettingsS, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM, 		getSettingsC, setSettingsC, getSettingsS, setSettingsS,@@ -69,7 +70,8 @@ 	DigitSigned(..), CCSpec(..), Finished(..) ) import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run (-	TlsM, run, HandleBase, getNames,+	TlsState(..), State1(..), wFlush, Keys(..),+	TlsM, run, run', HandleBase, getNames, 		chGet, hsPut, updateHash, ccsPut, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM,

@@ -1,6 +1,6 @@ {-| -Module		: Network.PeyoTLS.Server+Module		: Network.PeyoTLS.Client Copyright	: (c) Yoshikuni Jujo, 2014 License		: BSD3 Maintainer	: PAF01143@nifty.ne.jp@@ -8,8 +8,6 @@  -} -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}- module Network.PeyoTLS.Client ( 	-- * Basic 	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),@@ -21,292 +19,4 @@ 	-- * Others 	ValidateHandle(..), CertSecretKey(..) ) where -import Control.Applicative ((<$>), (<*>))-import Control.Monad (when, unless, liftM, ap)-import "monads-tf" Control.Monad.Error.Class (strMsg)-import Data.Maybe (fromMaybe)-import Data.List (find, intersect)-import Data.Function (on)-import Data.HandleLike (HandleLike(..))-import System.IO (Handle)-import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)--import qualified Data.ByteString as BS-import qualified Data.X509 as X509-import qualified Data.X509.CertificateStore as X509-import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.PubKey.DH as DH-import qualified Crypto.Types.PubKey.ECC as ECC--import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as RSA-import qualified "monads-tf" Control.Monad.Error as E--import qualified Network.PeyoTLS.Base as BASE (getNames)-import Network.PeyoTLS.Base ( debug,-	PeyotlsM, TlsM, run,-		getSettingsC, setSettingsC,-		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,-	HandshakeM, execHandshakeM, rerunHandshakeM,-		withRandom, flushAd,-		Alert(..), AlertLevel(..), AlertDesc(..), throw,-	ValidateHandle(..), handshakeValidate, validateAlert,-	HandleBase, CertSecretKey(..),-		readHandshake, writeHandshake, CCSpec(..),-	ClHello(..), SvHello(..), SssnId(..), isRnInfo,-		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CmpMtd(..), HashAlg(..), SignAlg(..),-		setCipherSuite,-		checkSvRenego, makeClRenego,-	SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..),-	CertReq(..), ClCertType(..),-	SHDone(..),-	ClKeyEx(..), Epms(..), makeKeys,-	DigitSigned(..), ClSignSecretKey(..), handshakeHash,-	Side(..), RW(..), finishedHash, flushCipherSuite,-	DhParam(..), ecdsaPubKey )--type PeyotlsHandle = TlsHandle Handle SystemRNG--newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show--instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where-	type HandleMonad (TlsHandle h g) = TlsM h g-	type DebugLevel (TlsHandle h g) = DebugLevel h-	hlPut = adPut . tlsHandleC-	hlGet = adGet rehandshake . tlsHandleC-	hlGetLine = adGetLine rehandshake . tlsHandleC-	hlGetContent = adGetContent rehandshake . tlsHandleC-	hlDebug = adDebug . tlsHandleC-	hlClose = adClose . tlsHandleC--modNm :: String-modNm = "Network.PeyoTLS.Client"--getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]-getNames = BASE.getNames . tlsHandleC--checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool-checkName t n = flip toCheckName n `liftM` getNames t--toCheckName :: [String] -> String -> Bool-toCheckName s0s s = any (`toCheckName1` s) s0s--toCheckName1 :: String -> String -> Bool-toCheckName1 = on checkSepNames $ sepBy '.'--sepBy :: Eq a => a ->[a] -> [[a]]-sepBy x0 xs-	| (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d-	| otherwise = [xs]--checkSepNames :: [String] -> [String] -> Bool-checkSepNames [] [] = True-checkSepNames _ [] = False-checkSepNames [] _ = False-checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns-checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns---- | Don't forget check server name by checkName.--open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] ->-	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	TlsM h g (TlsHandle h g)-open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do-	setSettingsC (cscl, crts, ca)-	handshake crts ca =<< clientHello cscl---- | This function open and check server name.---   Use this so as not to forget to check server name.--open' :: (ValidateHandle h, CPRG g) => h -> String -> [CipherSuite] ->-	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	TlsM h g (TlsHandle h g)-open' h n cscl crts ca = do-	t <- open h cscl crts ca-	c <- checkName t n-	unless c . E.throwError $ strMsg "certificate name mismatch"-	return t--renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()-renegotiate (TlsHandleC t) = rerunHandshakeM t $ do-	(cscl, crts, ca) <- getSettingsC-	clientHello cscl >>= \cr -> flushAd >>= flip when (handshake crts ca cr)--setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	[CipherSuite] -> TlsM h g ()-setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do-	(_, crts, cs) <- getSettingsC-	setSettingsC (cscl, crts, cs)--setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	[(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()-setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do-	(cscl, _, cs) <- getSettingsC-	setSettingsC (cscl, crts, cs)--setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	X509.CertificateStore -> TlsM h g ()-setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do-	(cscl, crts, _) <- getSettingsC-	setSettingsC (cscl, crts, cs)--rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g ()-rehandshake t = rerunHandshakeM t $ do-	(cscl, crts, ca) <- getSettingsC-	handshake crts ca =<< clientHello cscl--clientHello :: (HandleLike h, CPRG g) =>-	[CipherSuite] -> HandshakeM h g BS.ByteString-clientHello cscl = do-	cr <- withRandom $ cprgGenerate 32-	((>>) <$> writeHandshake <*> debug "low")-		. ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull]-		. Just . (: []) =<< makeClRenego-	return cr--handshake :: (ValidateHandle h, CPRG g) =>-	[(CertSecretKey, X509.CertificateChain)] ->-	X509.CertificateStore -> BS.ByteString -> HandshakeM h g ()-handshake crts ca cr = do-	(sr, ke) <- serverHello-	($ ca) . ($ crts) . ($ (cr, sr)) $ case ke of-		RSA -> rsaHandshake-		DHE_RSA -> dheHandshake (undefined :: DH.Params)-		ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve)-		ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve)-		_ -> \_ _ _ -> throw ALFtl ADHsFailure $-			modNm ++ ".handshake: not implemented"--serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx)-serverHello = do-	SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake-	case v of-		(3, 3) -> return ()-		_ -> throw ALFtl ADProtoVer $-			modNm ++ ".serverHello: only TLS 1.2"-	case cm of-		CmpMtdNull -> return ()-		_ -> throw ALFtl ADHsFailure $-			modNm ++ ".serverHello: only compression method null"-	case find isRnInfo $ fromMaybe [] e of-		Just ri -> checkSvRenego ri-		_ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego"-	setCipherSuite cs-	return (sr, ke)--rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) ->-	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	HandshakeM h g ()-rsaHandshake rs crts ca = do-	cc@(X509.CertificateChain (c : _)) <- readHandshake-	vr <- handshakeValidate ca cc-	unless (null vr) . throw ALFtl (validateAlert vr) $-		modNm ++ ".rsaHandshake: validate failure"-	pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of-		X509.PubKeyRSA k -> return k-		_ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk"-	crt <- clientCertificate crts-	pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46)-	makeKeys Client rs pms-	writeHandshake . Epms =<< encryptRsa pk pms-	finishHandshake crt--encryptRsa :: (HandleLike h, CPRG g) =>-	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString-encryptRsa pk p = either (E.throwError . strMsg . show) return =<<-	withRandom (\g -> RSA.encrypt g pk p)--dheHandshake :: (ValidateHandle h, CPRG g,-		KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) =>-	ke -> (BS.ByteString, BS.ByteString) ->-	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	HandshakeM h g ()-dheHandshake t rs crts ca = do-	cc@(X509.CertificateChain (c : _)) <- readHandshake-	vr <- handshakeValidate ca cc-	unless (null vr) . throw ALFtl (validateAlert vr) $-		modNm ++ ".succeed: validate failure"-	case X509.certPubKey . X509.signedObject $ X509.getSigned c of-		X509.PubKeyRSA pk -> succeed t pk rs crts-		X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts-		_ -> throw ALFtl ADHsFailure $-			modNm ++ ".dheHandshake: not implemented"--succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk,-		KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) =>-	ke -> pk -> (BS.ByteString, BS.ByteString) ->-	[(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g ()-succeed t pk rs@(cr, sr) crts = do-	(ps, pv, ha, sa, sn) <- serverKeyExchange-	let _ = ps `asTypeOf` t-	unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $-		pre ++ "sign algorithm unmatch"-	unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .-		throw ALFtl ADDecryptErr $ pre ++ "verify failure"-	crt <- clientCertificate crts-	sv <- withRandom $ generateSecret ps-	makeKeys Client rs $ calculateShared ps sv pv-	writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv-	finishHandshake crt-	where pre = modNm ++ ".succeed: "--class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where-	serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g-		(bs, Public bs, HashAlg, SignAlg, BS.ByteString)--instance KeyExchangeClass ECC.Curve where-	serverKeyExchange = do-		SvKeyExEcdhe cv pnt ha sa sn <- readHandshake-		return (cv, pnt, ha, sa, sn)--instance KeyExchangeClass DH.Params where-	serverKeyExchange = do-		SvKeyExDhe ps pv ha sa sn <- readHandshake-		return (ps, pv, ha, sa, sn)--clientCertificate :: (HandleLike h, CPRG g) =>-	[(CertSecretKey, X509.CertificateChain)] ->-	HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain))-clientCertificate crts = do-	h <- readHandshake-	(\p -> either p (\SHDone -> return Nothing) h) $ \(CertReq cct a dn) -> do-		SHDone <- readHandshake-		case find (isMatchedCert cct a dn) crts of-			Just c ->-				(>>) <$> writeHandshake . snd <*> return . Just $ c-			_ -> throw ALFtl ADUnkCa $ modNm ++-				".clientCertificate: no certificate"--isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] ->-	[X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool-isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd-	where-	obj = X509.signedObject . X509.getSigned-	rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa-	ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa-	csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa-	ccrt (X509.CertificateChain cs@(c : _)) =-		cpk (X509.certPubKey $ obj c) &&-		not (null . intersect dn $ map (X509.certIssuerDN . obj) cs)-	ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain"-	cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False--finishHandshake :: (HandleLike h, CPRG g) =>-	Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g ()-finishHandshake crt = do-	hs <- handshakeHash-	case fst <$> crt of-		Just (RsaKey sk) -> writeHandshake .-			DigitSigned (cssAlgorithm sk) $ csSign sk hs-		Just (EcdsaKey sk) -> writeHandshake .-			DigitSigned (cssAlgorithm sk) $ csSign sk hs-		_ -> return ()-	writeHandshake CCSpec-	flushCipherSuite Write-	writeHandshake =<< finishedHash Client-	CCSpec <- readHandshake-	flushCipherSuite Read-	(==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless-		(throw ALFtl ADDecryptErr $-			modNm ++ ".finishHandshake: finished hash failure")+import Network.PeyoTLS.Client.Body

@@ -0,0 +1,318 @@+{-|++Module		: Network.PeyoTLS.Server+Copyright	: (c) Yoshikuni Jujo, 2014+License		: BSD3+Maintainer	: PAF01143@nifty.ne.jp+Stability	: Experimental++-}++{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.PeyoTLS.Client.Body (+	-- * Basic+	TlsState(..), State1(..), Keys(..), toCheckName,+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),+	run, run', open, open', getNames, checkName,+	-- * Renegotiation+	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore,+	-- * Cipher Suite+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	-- * Others+	ValidateHandle(..), CertSecretKey(..) ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (when, unless, liftM, ap)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.Maybe (fromMaybe)+import Data.List (find, intersect)+import Data.Function (on)+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)++import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified "monads-tf" Control.Monad.Error as E++import qualified Network.PeyoTLS.Base as BASE (getNames)+import Network.PeyoTLS.Base ( debug, wFlush,+	TlsState(..), State1(..), Keys(..),+	PeyotlsM, TlsM, run, run',+		getSettingsC, setSettingsC,+		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,+	HandshakeM, execHandshakeM, rerunHandshakeM,+		withRandom, flushAd,+		Alert(..), AlertLevel(..), AlertDesc(..), throw,+	ValidateHandle(..), handshakeValidate, validateAlert,+	HandleBase, CertSecretKey(..),+		readHandshake, writeHandshake, CCSpec(..),+	ClHello(..), SvHello(..), SssnId(..), isRnInfo,+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), HashAlg(..), SignAlg(..),+		setCipherSuite,+		checkSvRenego, makeClRenego,+	SvKeyExEcdhe(..), SvKeyExDhe(..), SvSignPublicKey(..),+	CertReq(..), ClCertType(..),+	SHDone(..),+	ClKeyEx(..), Epms(..), makeKeys,+	DigitSigned(..), ClSignSecretKey(..), handshakeHash,+	Side(..), RW(..), finishedHash, flushCipherSuite,+	DhParam(..), ecdsaPubKey )++type PeyotlsHandle = TlsHandle Handle SystemRNG++newtype TlsHandle h g = TlsHandleC { tlsHandleC :: HandleBase h g } deriving Show++instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where+	type HandleMonad (TlsHandle h g) = TlsM h g+	type DebugLevel (TlsHandle h g) = DebugLevel h+	hlPut = adPut . tlsHandleC+	hlGet = adGet rehandshake . tlsHandleC+	hlGetLine = adGetLine rehandshake . tlsHandleC+	hlGetContent = adGetContent rehandshake . tlsHandleC+	hlDebug = adDebug . tlsHandleC+	hlClose = adClose . tlsHandleC+	hlFlush = writeFlush++writeFlush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()+writeFlush = wFlush . tlsHandleC++modNm :: String+modNm = "Network.PeyoTLS.Client"++getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]+getNames = BASE.getNames . tlsHandleC++checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool+checkName t n = flip toCheckName n `liftM` getNames t++toCheckName :: [String] -> String -> Bool+toCheckName s0s s = any (`toCheckName1` s) s0s++toCheckName1 :: String -> String -> Bool+toCheckName1 = on checkSepNames $ sepBy '.'++sepBy :: Eq a => a ->[a] -> [[a]]+sepBy x0 xs+	| (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d+	| otherwise = [xs]++checkSepNames :: [String] -> [String] -> Bool+checkSepNames [] [] = True+checkSepNames _ [] = False+checkSepNames [] _ = False+checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns+checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns++-- | Don't forget check server name by checkName.++open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] ->+	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+	TlsM h g (TlsHandle h g)+open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do+	setSettingsC (cscl, crts, ca)+	handshake crts ca =<< clientHello cscl++-- | This function open and check server name.+--   Use this so as not to forget to check server name.++open' :: (ValidateHandle h, CPRG g) => h -> String -> [CipherSuite] ->+	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+	TlsM h g (TlsHandle h g)+open' h n cscl crts ca = do+	t <- open h cscl crts ca+	c <- checkName t n+	unless c . E.throwError $ strMsg "certificate name mismatch"+	return t++renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+renegotiate (TlsHandleC t) = rerunHandshakeM t $ do+	(cscl, crts, ca) <- getSettingsC+	clientHello cscl >>= \cr -> flushAd >>= flip when (handshake crts ca cr)++setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	[CipherSuite] -> TlsM h g ()+setCipherSuites (TlsHandleC t) cscl = rerunHandshakeM t $ do+	(_, crts, cs) <- getSettingsC+	setSettingsC (cscl, crts, cs)++setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	[(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()+setKeyCerts (TlsHandleC t) crts = rerunHandshakeM t $ do+	(cscl, _, cs) <- getSettingsC+	setSettingsC (cscl, crts, cs)++setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	X509.CertificateStore -> TlsM h g ()+setCertificateStore (TlsHandleC t) cs = rerunHandshakeM t $ do+	(cscl, crts, _) <- getSettingsC+	setSettingsC (cscl, crts, cs)++rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g ()+rehandshake t = rerunHandshakeM t $ do+	(cscl, crts, ca) <- getSettingsC+	handshake crts ca =<< clientHello cscl++clientHello :: (HandleLike h, CPRG g) =>+	[CipherSuite] -> HandshakeM h g BS.ByteString+clientHello cscl = do+	cr <- withRandom $ cprgGenerate 32+	((>>) <$> writeHandshake <*> debug "low")+		. ClHello (3, 3) cr (SssnId "") cscl [CmpMtdNull]+		. Just . (: []) =<< makeClRenego+	return cr++handshake :: (ValidateHandle h, CPRG g) =>+	[(CertSecretKey, X509.CertificateChain)] ->+	X509.CertificateStore -> BS.ByteString -> HandshakeM h g ()+handshake crts ca cr = do+	(sr, ke) <- serverHello+	($ ca) . ($ crts) . ($ (cr, sr)) $ case ke of+		RSA -> rsaHandshake+		DHE_RSA -> dheHandshake (undefined :: DH.Params)+		ECDHE_RSA -> dheHandshake (undefined :: ECC.Curve)+		ECDHE_ECDSA -> dheHandshake (undefined :: ECC.Curve)+		_ -> \_ _ _ -> throw ALFtl ADHsFailure $+			modNm ++ ".handshake: not implemented"++serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx)+serverHello = do+	SvHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake+	case v of+		(3, 3) -> return ()+		_ -> throw ALFtl ADProtoVer $+			modNm ++ ".serverHello: only TLS 1.2"+	case cm of+		CmpMtdNull -> return ()+		_ -> throw ALFtl ADHsFailure $+			modNm ++ ".serverHello: only compression method null"+	case find isRnInfo $ fromMaybe [] e of+		Just ri -> checkSvRenego ri+		_ -> throw ALFtl ADInsSec $ modNm ++ ".serverHello: no sec renego"+	setCipherSuite cs+	return (sr, ke)++rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) ->+	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+	HandshakeM h g ()+rsaHandshake rs crts ca = do+	cc@(X509.CertificateChain (c : _)) <- readHandshake+	vr <- handshakeValidate ca cc+	unless (null vr) . throw ALFtl (validateAlert vr) $+		modNm ++ ".rsaHandshake: validate failure"+	pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of+		X509.PubKeyRSA k -> return k+		_ -> throw ALFtl ADIllParam $ modNm ++ ".rsaHandshake: RSA pk"+	crt <- clientCertificate crts+	pms <- ("\x03\x03" `BS.append`) `liftM` withRandom (cprgGenerate 46)+	makeKeys Client rs pms+	writeHandshake . Epms =<< encryptRsa pk pms+	finishHandshake crt++encryptRsa :: (HandleLike h, CPRG g) =>+	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString+encryptRsa pk p = either (E.throwError . strMsg . show) return =<<+	withRandom (\g -> RSA.encrypt g pk p)++dheHandshake :: (ValidateHandle h, CPRG g,+		KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) =>+	ke -> (BS.ByteString, BS.ByteString) ->+	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->+	HandshakeM h g ()+dheHandshake t rs crts ca = do+	cc@(X509.CertificateChain (c : _)) <- readHandshake+	vr <- handshakeValidate ca cc+	unless (null vr) . throw ALFtl (validateAlert vr) $+		modNm ++ ".succeed: validate failure"+	case X509.certPubKey . X509.signedObject $ X509.getSigned c of+		X509.PubKeyRSA pk -> succeed t pk rs crts+		X509.PubKeyECDSA cv pt -> succeed t (ecdsaPubKey cv pt) rs crts+		_ -> throw ALFtl ADHsFailure $+			modNm ++ ".dheHandshake: not implemented"++succeed :: (ValidateHandle h, CPRG g, SvSignPublicKey pk,+		KeyExchangeClass ke, Show (Secret ke), Show (Public ke)) =>+	ke -> pk -> (BS.ByteString, BS.ByteString) ->+	[(CertSecretKey, X509.CertificateChain)] -> HandshakeM h g ()+succeed t pk rs@(cr, sr) crts = do+	(ps, pv, ha, sa, sn) <- serverKeyExchange+	let _ = ps `asTypeOf` t+	unless (sa == sspAlgorithm pk) . throw ALFtl ADHsFailure $+		pre ++ "sign algorithm unmatch"+	unless (ssVerify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .+		throw ALFtl ADDecryptErr $ pre ++ "verify failure"+	crt <- clientCertificate crts+	sv <- withRandom $ generateSecret ps+	makeKeys Client rs $ calculateShared ps sv pv+	writeHandshake . ClKeyEx . B.encode $ calculatePublic ps sv+	finishHandshake crt+	where pre = modNm ++ ".succeed: "++class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where+	serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g+		(bs, Public bs, HashAlg, SignAlg, BS.ByteString)++instance KeyExchangeClass ECC.Curve where+	serverKeyExchange = do+		SvKeyExEcdhe cv pnt ha sa sn <- readHandshake+		return (cv, pnt, ha, sa, sn)++instance KeyExchangeClass DH.Params where+	serverKeyExchange = do+		SvKeyExDhe ps pv ha sa sn <- readHandshake+		return (ps, pv, ha, sa, sn)++clientCertificate :: (HandleLike h, CPRG g) =>+	[(CertSecretKey, X509.CertificateChain)] ->+	HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain))+clientCertificate crts = do+	h <- readHandshake+	(\p -> either p (\SHDone -> return Nothing) h) $ \(CertReq cct a dn) -> do+		SHDone <- readHandshake+		case find (isMatchedCert cct a dn) crts of+			Just c ->+				(>>) <$> writeHandshake . snd <*> return . Just $ c+			_ -> throw ALFtl ADUnkCa $ modNm +++				".clientCertificate: no certificate"++isMatchedCert :: [ClCertType] -> [(HashAlg, SignAlg)] ->+	[X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool+isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd+	where+	obj = X509.signedObject . X509.getSigned+	rsa = CTRsaSign `elem` ct || Rsa `elem` map snd hsa+	ecdsa = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa+	csk (RsaKey _) = rsa; csk (EcdsaKey _) = ecdsa+	ccrt (X509.CertificateChain cs@(c : _)) =+		cpk (X509.certPubKey $ obj c) &&+		not (null . intersect dn $ map (X509.certIssuerDN . obj) cs)+	ccrt _ = error $ modNm ++ ".isMatchedCert: empty certificate chain"+	cpk X509.PubKeyRSA{} = rsa; cpk X509.PubKeyECDSA{} = ecdsa; cpk _ = False++finishHandshake :: (HandleLike h, CPRG g) =>+	Maybe (CertSecretKey, X509.CertificateChain) -> HandshakeM h g ()+finishHandshake crt = do+	hs <- handshakeHash+	case fst <$> crt of+		Just (RsaKey sk) -> writeHandshake .+			DigitSigned (cssAlgorithm sk) $ csSign sk hs+		Just (EcdsaKey sk) -> writeHandshake .+			DigitSigned (cssAlgorithm sk) $ csSign sk hs+		_ -> return ()+	writeHandshake CCSpec+	flushCipherSuite Write+	writeHandshake =<< finishedHash Client+	CCSpec <- readHandshake+	flushCipherSuite Read+	(==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless+		(throw ALFtl ADDecryptErr $+			modNm ++ ".finishHandshake: finished hash failure")

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections, PackageImports #-}  module Network.PeyoTLS.Run ( H.debug,-	H.TlsM, H.run, H.HandleBase,+	H.TlsState(..), H.State1(..), H.wFlush, H.Keys(..),+	H.TlsM, H.run, H.run', H.HandleBase, 		adGet, adGetLine, adGetContent, H.adPut, H.adDebug, H.adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM, withRandom, 		chGet, ccsPut, hsPut, updateHash, flushAd,@@ -35,7 +36,8 @@ import qualified Crypto.Hash.SHA256 as SHA256  import qualified Network.PeyoTLS.Run.Handle as H ( debug,-	TlsM, run, withRandom,+	TlsState(..), State1(..), wFlush, Keys(..),+	TlsM, run, run', withRandom, 	HandleBase, CipherSuite, 		newHandle, chGet, ccsPut, hsPut, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,

@@ -58,7 +58,8 @@ decrypt :: (Hash, Int) -> BS.ByteString -> BS.ByteString -> Word64 -> 	BS.ByteString -> BS.ByteString -> Either String BS.ByteString decrypt (hs, ml) k mk sn pre enc =-	if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n"+	if rm == em then Right b else Left $ modNm ++ ".decrypt: bad MAC\n" +++		"\t"++ show b ++ "\n" 	where 	pln = uncurry (AES.decryptCBC $ AES.initAES k) $ BS.splitAt 16 enc 	up = BS.take (BS.length pln - fromIntegral (lst pln) - 1) pln

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}  module Network.PeyoTLS.Run.Handle ( debug,-	M.TlsM, M.run, M.withRandom,+	M.TlsState(..), M.State1(..), wFlush, M.Keys(..),+	M.TlsM, M.run, M.run', M.withRandom, 	HandleBase, M.CipherSuite, 		newHandle, chGet, ccsPut, hsPut, 		adGet, adGetLine, splitLine, adGetContent, adPut, adDebug, adClose,@@ -33,7 +34,8 @@ import qualified Codec.Bytable.BigEndian as B  import qualified Network.PeyoTLS.Run.Monad as M (-	TlsM, run, throw, withRandom,+	TlsState(..), State1(..),+	TlsM, run, run', throw, withRandom, 		Alert(..), AlertLevel(..), AlertDesc(..), 		tGet, decrypt, tPut, encrypt, tClose, tDebug, 	PartnerId, newPartner, ContType(..),

@@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings, PackageImports #-}  module Network.PeyoTLS.Run.Monad (-	TlsM, run, throw, withRandom,+	S.TlsState(..), S.State1(..),++	TlsM, run, run', throw, withRandom, 		Alert(..), AlertLevel(..), AlertDesc(..), 		tGet, decrypt, tPut, encrypt, tClose, tDebug, 	S.PartnerId, S.newPartner, S.ContType(..),@@ -17,7 +19,8 @@  import Control.Arrow ((***)) import Control.Monad (unless, liftM, ap)-import "monads-tf" Control.Monad.State (lift, StateT, evalStateT, gets, modify)+import "monads-tf" Control.Monad.State+	(lift, StateT, runStateT, evalStateT, gets, modify) import "monads-tf" Control.Monad.Error (ErrorT, runErrorT, throwError) import "monads-tf" Control.Monad.Error.Class (Error(..)) import Data.Word (Word8, Word64)@@ -27,8 +30,8 @@ import qualified Data.ByteString as BS import qualified Codec.Bytable.BigEndian as B -import qualified Network.PeyoTLS.Run.State as S (-	TlsState, initState, PartnerId, newPartner,+import qualified Network.PeyoTLS.Run.State as S (State1(..), Keys(..),+	TlsState(..), initState, PartnerId, newPartner, 		getGen, setGen, getNames, setNames, 		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, 		getClFinished, getSvFinished, setClFinished, setSvFinished,@@ -52,8 +55,15 @@  run :: HandleLike h => TlsM h g a -> g -> HandleMonad h a run m g = evalStateT (runErrorT m) (S.initState g) >>= \er -> case er of-		Right r -> return r-		Left a -> error $ show a+	Right r -> return r+	Left a -> error $ show a++run' :: HandleLike h => TlsM h g a -> g -> HandleMonad h ((S.Keys, [String]), g)+run' m g = runStateT (runErrorT m) (S.initState g) >>= \er -> case er of+	(Right _, s) -> return ((+		S.sKeys . snd . head $ S.states s,+		S.sNames . snd . head $ S.states s ), S.gen s)+	(Left a, _) -> error $ show a  throw :: HandleLike h => AlertLevel -> AlertDesc -> String -> TlsM h g a throw = ((throwError .) .) . Alert

@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TupleSections #-} -module Network.PeyoTLS.Run.State (-	TlsState, initState, PartnerId, newPartner,+module Network.PeyoTLS.Run.State ( State1(..),+	TlsState(..), initState, PartnerId, newPartner, 		getGen, setGen, getNames, setNames, 		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, 		getClFinished, setClFinished, getSvFinished, setSvFinished,

@@ -8,11 +8,10 @@  -} -{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}- module Network.PeyoTLS.Server ( 	-- * Basic-	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..), run, open, getNames,+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),+	run, open, getNames, 	-- * Renegotiation 	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, 	-- * Cipher Suite@@ -20,282 +19,4 @@ 	-- * Others 	ValidateHandle(..), CertSecretKey(..) ) where -import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first)-import Control.Monad (when, unless, liftM, ap)-import "monads-tf" Control.Monad.Error (catchError)-import "monads-tf" Control.Monad.Error.Class (strMsg)-import Data.List (find)-import Data.Word (Word8)-import Data.HandleLike (HandleLike(..))-import System.IO (Handle)-import Numeric (readHex)-import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)--import qualified "monads-tf" Control.Monad.Error as E-import qualified Data.ByteString as BS-import qualified Data.X509 as X509-import qualified Data.X509.CertificateStore as X509-import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as RSA-import qualified Crypto.Types.PubKey.DH as DH-import qualified Crypto.Types.PubKey.ECC as ECC--import qualified Network.PeyoTLS.Base as BASE (getNames)-import Network.PeyoTLS.Base ( debug,-	PeyotlsM, TlsM, run,-		SettingsS, getSettingsS, setSettingsS,-		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,-	HandshakeM, execHandshakeM, rerunHandshakeM,-		withRandom, flushAd,-		Alert(..), AlertLevel(..), AlertDesc(..), throw, debugCipherSuite,-	ValidateHandle(..), handshakeValidate, validateAlert,-	HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,-		readHandshake, writeHandshake, CCSpec(..),-	Handshake(HHelloReq),-	ClHello(..), SvHello(..), SssnId(..), Extension(..),-		isRnInfo, emptyRnInfo,-		CipherSuite(..), KeyEx(..), BulkEnc(..),-		CmpMtd(..), HashAlg(..), SignAlg(..),-		getCipherSuite, setCipherSuite,-		checkClRenego, makeSvRenego,-	SvKeyEx(..), SvSignSecretKey(..),-	certReq, ClCertType(..),-	SHDone(..),-	ClKeyEx(..), Epms(..), makeKeys,-	DigitSigned(..), ClSignPublicKey(..), handshakeHash,-	RW(..), flushCipherSuite,-	Side(..), finishedHash,-	DhParam(..), ecdsaPubKey )--type PeyotlsHandle = TlsHandle Handle SystemRNG--newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show--instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where-	type HandleMonad (TlsHandle h g) = TlsM h g-	type DebugLevel (TlsHandle h g) = DebugLevel h-	hlPut = adPut . tlsHandleS-	hlGet = adGet rehandshake . tlsHandleS-	hlGetLine = adGetLine rehandshake . tlsHandleS-	hlGetContent = adGetContent rehandshake . tlsHandleS-	hlDebug = adDebug . tlsHandleS-	hlClose = adClose . tlsHandleS--type Version = (Word8, Word8)--version :: Version-version = (3, 3)--moduleName :: String-moduleName = "Network.PeyoTLS.Server"--getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]-getNames = BASE.getNames . tlsHandleS--open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] ->-	[(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore ->-	TlsM h g (TlsHandle h g)-open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $-	((>>) <$> setSettingsS <*> handshake) (cssv',-		first rsaKey <$> find (isRsaKey . fst) crts,-		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs )-	where-	cssv' = filter iscs $ case find (isEcdsaKey . fst) crts of-		Just _ -> cssv-		_ -> flip filter cssv $ \cs -> case cs of-			CipherSuite ECDHE_ECDSA _ -> False-			_ -> True-	iscs (CipherSuiteRaw _ _) = False-	iscs EMPTY_RENEGOTIATION_INFO = False-	iscs _ = True--setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	[CipherSuite] -> TlsM h g ()-setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do-	(_, rcrt, ecrt, mcs) <- getSettingsS-	setSettingsS (cssv, rcrt, ecrt, mcs)--setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	[(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()-setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do-	(cssv, _, _, mcs) <- getSettingsS-	setSettingsS (cssv,-		first rsaKey <$> find (isRsaKey . fst) crts,-		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)--setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->-	Maybe X509.CertificateStore -> TlsM h g ()-setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do-	(cssv, rcrt, ecrt, _) <- getSettingsS-	setSettingsS (cssv, rcrt, ecrt, mcs)--renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()-renegotiate (TlsHandleS t) = rerunHandshakeM t $ do-	writeHandshake HHelloReq-	debug "low" ("before flushAd" :: String)-	ne <- flushAd-	debug "low" ("after flushAd" :: String)-	when ne (handshake =<< getSettingsS)--rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g ()-rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS--handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g ()-handshake (cssv, rcrt, ecrt, mcs) = do-	(ke, be, cr, cv) <- clientHello cssv-	sr <- serverHello (snd <$> rcrt) (snd <$> ecrt)-	ha <- case be of-		AES_128_CBC_SHA -> return Sha1-		AES_128_CBC_SHA256 -> return Sha256-		_ -> throw ALFtl ADInternalErr $-			pre ++ "not implemented bulk encryption type"-	mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of-		(RSA, Just rsk, _) -> rsaKeyExchange rsk cv-		(DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk-		(ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk-		(ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk-		_ -> \_ _ -> throw ALFtl ADInternalErr $-			pre ++ "no implemented key exchange type or " ++-				"no applicable certificate files"-	flip (maybe $ return ()) mpk $ \pk -> case pk of-		X509.PubKeyRSA rpk -> certVerify rpk-		X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy-		_ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk-	CCSpec <- readHandshake-	flushCipherSuite Read-	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok .-		throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash"-	writeHandshake CCSpec-	flushCipherSuite Write-	writeHandshake =<< finishedHash Server-	where pre = moduleName ++ ".handshake: "--secp256r1 :: ECC.Curve-secp256r1 = ECC.getCurveByName ECC.SEC_p256r1--dh3072Modp :: DH.Params-dh3072Modp = DH.Params p 2-	where [(p, "")] = readHex $-		"ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" ++-		"29024e088a67cc74020bbea63b139b22514a08798e3404dd" ++-		"ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" ++-		"e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" ++-		"ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" ++-		"c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" ++-		"83655d23dca3ad961c62f356208552bb9ed529077096966d" ++-		"670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" ++-		"e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" ++-		"de2bcbf6955817183995497cea956ae515d2261898fa0510" ++-		"15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" ++-		"ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" ++-		"abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" ++-		"f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" ++-		"bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" ++-		"43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"--clientHello :: (HandleLike h, CPRG g) => [CipherSuite] ->-	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version)-clientHello cssv = do-	ClHello cv cr _sid cscl cms me <- readHandshake-	checkRnInfo cscl me-	unless (cv >= version) . throw ALFtl ADProtoVer $-		pre ++ "only implement TLS 1.2"-	unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $-		pre ++ "compression method NULL must be supported"-	(ke, be) <- case find (`elem` cscl) cssv of-		Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b)-		_ -> throw ALFtl ADHsFailure $-			pre ++ "no acceptable set of security parameters: \n\t" ++-			"cscl: " ++ show cscl ++ "\n\t" ++-			"cssv: " ++ show cssv ++ "\n"-	return (ke, be, cr, cv)-	where pre = moduleName ++ ".clientHello: "--checkRnInfo ::-	HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()-checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw-	ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation"-	where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of-		(True, _) -> Just emptyRnInfo-		(_, Just e) -> find isRnInfo e-		(_, _) -> Nothing--serverHello :: (HandleLike h, CPRG g) =>-	Maybe X509.CertificateChain -> Maybe X509.CertificateChain ->-	HandshakeM h g BS.ByteString-serverHello rcc ecc = do-	cs <- getCipherSuite-	ke <- case cs of-		CipherSuite k _ -> return k-		_ -> throw ALFtl ADInternalErr $-			moduleName ++ ".serverHello: never occur"-	sr <- withRandom $ cprgGenerate 32-	writeHandshake-		. SvHello version sr (SssnId "") cs CmpMtdNull-		. Just . (: []) =<< makeSvRenego-	writeHandshake =<< case (ke, rcc, ecc) of-		(ECDHE_ECDSA, _, Just c) -> return c-		(_, Just c, _) -> return c-		_ -> throw ALFtl ADInternalErr $-			moduleName ++ ".serverHello: cert files not match"-	return sr--rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version ->-	(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->-	HandshakeM h g (Maybe X509.PubKey)-rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do-	Epms epms <- readHandshake-	makeKeys Server rs =<< mkpms epms `catchError` const-		((BS.cons vj . BS.cons vn) `liftM` withRandom (cprgGenerate 46))-	where mkpms epms = do-		pms <- either (E.throwError . strMsg . show) return =<<-			withRandom (\g -> RSA.decryptSafer g sk epms)-		unless (BS.length pms == 48) $ throw ALFtl ADHsFailure ""-		let [pvj, pvn] = BS.unpack $ BS.take 2 pms-		unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure ""-		return pms--dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk,-		DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>-	HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) ->-	Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)-dhKeyExchange ha dp sk rs@(cr, sr) mcs = do-	sv <- withRandom $ generateSecret dp-	bl <- withRandom $ generateBlinder sk-	let pv = B.encode $ calculatePublic dp sv-	writeHandshake-		. SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk)-		. ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv]-	const `liftM` reqAndCert mcs `ap` do-		ClKeyEx cke <- readHandshake-		makeKeys Server rs . calculateShared dp sv =<<-			either (throw ALFtl ADInternalErr .-					(moduleName ++) . (".dhKeyExchange: " ++))-				return (B.decode cke)--reqAndCert :: (ValidateHandle h, CPRG g) =>-	Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)-reqAndCert mcs = do-	flip (maybe $ return ()) mcs $ writeHandshake . certReq-		[CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)]-	writeHandshake SHDone-	flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do-		cc@(X509.CertificateChain (c : _)) <- readHandshake-		vr <- handshakeValidate cs cc-		unless (null vr) . throw ALFtl (validateAlert vr) $-			moduleName ++ ".reqAndCert: " ++ show vr-		return . X509.certPubKey $ X509.getCertificate c--certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g ()-certVerify pk = do-	debugCipherSuite . show $ cspAlgorithm pk-	hs0 <- handshakeHash-	DigitSigned a s <- readHandshake-	case a of-		(Sha256, sa) | sa == cspAlgorithm pk -> return ()-		_ -> throw ALFtl ADDecodeErr $-			moduleName ++ ".certVerify: not implement: " ++ show a-	unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $-		moduleName ++ ".certVerify: client auth failed "+import Network.PeyoTLS.Server.Body

@@ -0,0 +1,324 @@+{-|++Module		: Network.PeyoTLS.Server+Copyright	: (c) Yoshikuni Jujo, 2014+License		: BSD3+Maintainer	: PAF01143@nifty.ne.jp+Stability	: Experimental++-}++{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}++module Network.PeyoTLS.Server.Body (+	Keys(..), toCheckName,+	-- * Basic+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),+	run, run', open, getNames,+	-- * Renegotiation+	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore,+	-- * Cipher Suite+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	-- * Others+	ValidateHandle(..), CertSecretKey(..) ) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first)+import Control.Monad (when, unless, liftM, ap)+import "monads-tf" Control.Monad.Error (catchError)+import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.List (find)+import Data.Word (Word8)+import Data.Function+import Data.HandleLike (HandleLike(..))+import System.IO (Handle)+import Numeric (readHex)+import "crypto-random" Crypto.Random (CPRG, SystemRNG, cprgGenerate)++import qualified "monads-tf" Control.Monad.Error as E+import qualified Data.ByteString as BS+import qualified Data.X509 as X509+import qualified Data.X509.CertificateStore as X509+import qualified Codec.Bytable.BigEndian as B+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified Crypto.Types.PubKey.DH as DH+import qualified Crypto.Types.PubKey.ECC as ECC++import qualified Network.PeyoTLS.Base as BASE (getNames)+import Network.PeyoTLS.Base ( debug, Keys(..),+	PeyotlsM, TlsM, run, run', wFlush,+		SettingsS, getSettingsS, setSettingsS,+		adGet, adGetLine, adGetContent, adPut, adDebug, adClose,+	HandshakeM, execHandshakeM, rerunHandshakeM,+		withRandom, flushAd,+		Alert(..), AlertLevel(..), AlertDesc(..), throw, debugCipherSuite,+	ValidateHandle(..), handshakeValidate, validateAlert,+	HandleBase, CertSecretKey(..), isRsaKey, isEcdsaKey,+		readHandshake, writeHandshake, CCSpec(..),+	Handshake(HHelloReq),+	ClHello(..), SvHello(..), SssnId(..), Extension(..),+		isRnInfo, emptyRnInfo,+		CipherSuite(..), KeyEx(..), BulkEnc(..),+		CmpMtd(..), HashAlg(..), SignAlg(..),+		getCipherSuite, setCipherSuite,+		checkClRenego, makeSvRenego,+	SvKeyEx(..), SvSignSecretKey(..),+	certReq, ClCertType(..),+	SHDone(..),+	ClKeyEx(..), Epms(..), makeKeys,+	DigitSigned(..), ClSignPublicKey(..), handshakeHash,+	RW(..), flushCipherSuite,+	Side(..), finishedHash,+	DhParam(..), ecdsaPubKey )++type PeyotlsHandle = TlsHandle Handle SystemRNG++newtype TlsHandle h g = TlsHandleS { tlsHandleS :: HandleBase h g } deriving Show++instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandle h g) where+	type HandleMonad (TlsHandle h g) = TlsM h g+	type DebugLevel (TlsHandle h g) = DebugLevel h+	hlPut = adPut . tlsHandleS+	hlGet = adGet rehandshake . tlsHandleS+	hlGetLine = adGetLine rehandshake . tlsHandleS+	hlGetContent = adGetContent rehandshake . tlsHandleS+	hlDebug = adDebug . tlsHandleS+	hlClose = adClose . tlsHandleS+	hlFlush = wFlush . tlsHandleS++type Version = (Word8, Word8)++version :: Version+version = (3, 3)++moduleName :: String+moduleName = "Network.PeyoTLS.Server"++getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String]+getNames = BASE.getNames . tlsHandleS++open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] ->+	[(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore ->+	TlsM h g (TlsHandle h g)+open h cssv crts mcs = liftM TlsHandleS . execHandshakeM h $+	((>>) <$> setSettingsS <*> handshake) (cssv',+		first rsaKey <$> find (isRsaKey . fst) crts,+		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs )+	where+	cssv' = filter iscs $ case find (isEcdsaKey . fst) crts of+		Just _ -> cssv+		_ -> flip filter cssv $ \cs -> case cs of+			CipherSuite ECDHE_ECDSA _ -> False+			_ -> True+	iscs (CipherSuiteRaw _ _) = False+	iscs EMPTY_RENEGOTIATION_INFO = False+	iscs _ = True++setCipherSuites :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	[CipherSuite] -> TlsM h g ()+setCipherSuites (TlsHandleS t) cssv = rerunHandshakeM t $ do+	(_, rcrt, ecrt, mcs) <- getSettingsS+	setSettingsS (cssv, rcrt, ecrt, mcs)++setKeyCerts :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	[(CertSecretKey, X509.CertificateChain)] -> TlsM h g ()+setKeyCerts (TlsHandleS t) crts = rerunHandshakeM t $ do+	(cssv, _, _, mcs) <- getSettingsS+	setSettingsS (cssv,+		first rsaKey <$> find (isRsaKey . fst) crts,+		first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)++setCertificateStore :: (ValidateHandle h, CPRG g) => TlsHandle h g ->+	Maybe X509.CertificateStore -> TlsM h g ()+setCertificateStore (TlsHandleS t) mcs = rerunHandshakeM t $ do+	(cssv, rcrt, ecrt, _) <- getSettingsS+	setSettingsS (cssv, rcrt, ecrt, mcs)++renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+renegotiate (TlsHandleS t) = rerunHandshakeM t $ do+	writeHandshake HHelloReq+	debug "low" ("before flushAd" :: String)+	ne <- flushAd+	debug "low" ("after flushAd" :: String)+	when ne (handshake =<< getSettingsS)++rehandshake :: (ValidateHandle h, CPRG g) => HandleBase h g -> TlsM h g ()+rehandshake t = rerunHandshakeM t $ handshake =<< getSettingsS++handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g ()+handshake (cssv, rcrt, ecrt, mcs) = do+	(ke, be, cr, cv) <- clientHello cssv+	sr <- serverHello (snd <$> rcrt) (snd <$> ecrt)+	ha <- case be of+		AES_128_CBC_SHA -> return Sha1+		AES_128_CBC_SHA256 -> return Sha256+		_ -> throw ALFtl ADInternalErr $+			pre ++ "not implemented bulk encryption type"+	mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, fst <$> rcrt, fst <$> ecrt) of+		(RSA, Just rsk, _) -> rsaKeyExchange rsk cv+		(DHE_RSA, Just rsk, _) -> dhKeyExchange ha dh3072Modp rsk+		(ECDHE_RSA, Just rsk, _) -> dhKeyExchange ha secp256r1 rsk+		(ECDHE_ECDSA, _, Just esk) -> dhKeyExchange ha secp256r1 esk+		_ -> \_ _ -> throw ALFtl ADInternalErr $+			pre ++ "no implemented key exchange type or " +++				"no applicable certificate files"+	flip (maybe $ return ()) mpk $ \pk -> case pk of+		X509.PubKeyRSA rpk -> certVerify rpk+		X509.PubKeyECDSA c xy -> certVerify $ ecdsaPubKey c xy+		_ -> throw ALFtl ADUnsCert $ pre ++ "not implement: " ++ show pk+	CCSpec <- readHandshake+	flushCipherSuite Read+	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok .+		throw ALFtl ADDecryptErr $ pre ++ "wrong finished hash"+	writeHandshake CCSpec+	flushCipherSuite Write+	writeHandshake =<< finishedHash Server+	where pre = moduleName ++ ".handshake: "++secp256r1 :: ECC.Curve+secp256r1 = ECC.getCurveByName ECC.SEC_p256r1++dh3072Modp :: DH.Params+dh3072Modp = DH.Params p 2+	where [(p, "")] = readHex $+		"ffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd1" +++		"29024e088a67cc74020bbea63b139b22514a08798e3404dd" +++		"ef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245" +++		"e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7ed" +++		"ee386bfb5a899fa5ae9f24117c4b1fe649286651ece45b3d" +++		"c2007cb8a163bf0598da48361c55d39a69163fa8fd24cf5f" +++		"83655d23dca3ad961c62f356208552bb9ed529077096966d" +++		"670c354e4abc9804f1746c08ca18217c32905e462e36ce3b" +++		"e39e772c180e86039b2783a2ec07a28fb5c55df06f4c52c9" +++		"de2bcbf6955817183995497cea956ae515d2261898fa0510" +++		"15728e5a8aaac42dad33170d04507a33a85521abdf1cba64" +++		"ecfb850458dbef0a8aea71575d060c7db3970f85a6e1e4c7" +++		"abf5ae8cdb0933d71e8c94e04a25619dcee3d2261ad2ee6b" +++		"f12ffa06d98a0864d87602733ec86a64521f2b18177b200c" +++		"bbe117577a615d6c770988c0bad946e208e24fa074e5ab31" +++		"43db5bfce0fd108e4b82d120a93ad2caffffffffffffffff"++clientHello :: (HandleLike h, CPRG g) => [CipherSuite] ->+	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version)+clientHello cssv = do+	ClHello cv cr _sid cscl cms me <- readHandshake+	checkRnInfo cscl me+	unless (cv >= version) . throw ALFtl ADProtoVer $+		pre ++ "only implement TLS 1.2"+	unless (CmpMtdNull `elem` cms) . throw ALFtl ADDecodeErr $+		pre ++ "compression method NULL must be supported"+	(ke, be) <- case find (`elem` cscl) cssv of+		Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b)+		_ -> throw ALFtl ADHsFailure $+			pre ++ "no acceptable set of security parameters: \n\t" +++			"cscl: " ++ show cscl ++ "\n\t" +++			"cssv: " ++ show cssv ++ "\n"+	return (ke, be, cr, cv)+	where pre = moduleName ++ ".clientHello: "++checkRnInfo ::+	HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()+checkRnInfo cscl me = (\n -> maybe n checkClRenego mcf) . throw+	ALFtl ADInsSec $ moduleName ++ ".checkRenego: require secure renegotiation"+	where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of+		(True, _) -> Just emptyRnInfo+		(_, Just e) -> find isRnInfo e+		(_, _) -> Nothing++serverHello :: (HandleLike h, CPRG g) =>+	Maybe X509.CertificateChain -> Maybe X509.CertificateChain ->+	HandshakeM h g BS.ByteString+serverHello rcc ecc = do+	cs <- getCipherSuite+	ke <- case cs of+		CipherSuite k _ -> return k+		_ -> throw ALFtl ADInternalErr $+			moduleName ++ ".serverHello: never occur"+	sr <- withRandom $ cprgGenerate 32+	writeHandshake+		. SvHello version sr (SssnId "") cs CmpMtdNull+		. Just . (: []) =<< makeSvRenego+	writeHandshake =<< case (ke, rcc, ecc) of+		(ECDHE_ECDSA, _, Just c) -> return c+		(_, Just c, _) -> return c+		_ -> throw ALFtl ADInternalErr $+			moduleName ++ ".serverHello: cert files not match"+	return sr++rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version ->+	(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore ->+	HandshakeM h g (Maybe X509.PubKey)+rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do+	Epms epms <- readHandshake+	makeKeys Server rs =<< mkpms epms `catchError` const+		((BS.cons vj . BS.cons vn) `liftM` withRandom (cprgGenerate 46))+	where mkpms epms = do+		pms <- either (E.throwError . strMsg . show) return =<<+			withRandom (\g -> RSA.decryptSafer g sk epms)+		unless (BS.length pms == 48) $ throw ALFtl ADHsFailure ""+		let [pvj, pvn] = BS.unpack $ BS.take 2 pms+		unless (pvj == vj && pvn == vn) $ throw ALFtl ADHsFailure ""+		return pms++dhKeyExchange :: (ValidateHandle h, CPRG g, SvSignSecretKey sk,+		DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>+	HashAlg -> dp -> sk -> (BS.ByteString, BS.ByteString) ->+	Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)+dhKeyExchange ha dp sk rs@(cr, sr) mcs = do+	sv <- withRandom $ generateSecret dp+	bl <- withRandom $ generateBlinder sk+	let pv = B.encode $ calculatePublic dp sv+	writeHandshake+		. SvKeyEx (B.encode dp) pv ha (sssAlgorithm sk)+		. ssSign sk ha bl $ BS.concat [cr, sr, B.encode dp, pv]+	const `liftM` reqAndCert mcs `ap` do+		ClKeyEx cke <- readHandshake+		makeKeys Server rs . calculateShared dp sv =<<+			either (throw ALFtl ADInternalErr .+					(moduleName ++) . (".dhKeyExchange: " ++))+				return (B.decode cke)++reqAndCert :: (ValidateHandle h, CPRG g) =>+	Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)+reqAndCert mcs = do+	flip (maybe $ return ()) mcs $ writeHandshake . certReq+		[CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)]+	writeHandshake SHDone+	flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do+		cc@(X509.CertificateChain (c : _)) <- readHandshake+		vr <- handshakeValidate cs cc+		unless (null vr) . throw ALFtl (validateAlert vr) $+			moduleName ++ ".reqAndCert: " ++ show vr+		return . X509.certPubKey $ X509.getCertificate c++certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g ()+certVerify pk = do+	debugCipherSuite . show $ cspAlgorithm pk+	hs0 <- handshakeHash+	DigitSigned a s <- readHandshake+	case a of+		(Sha256, sa) | sa == cspAlgorithm pk -> return ()+		_ -> throw ALFtl ADDecodeErr $+			moduleName ++ ".certVerify: not implement: " ++ show a+	unless (csVerify pk s hs0) . throw ALFtl ADDecryptErr $+		moduleName ++ ".certVerify: client auth failed "++toCheckName :: [String] -> Maybe (String -> Bool)+toCheckName [] = Nothing+toCheckName s0s = Just $ \s -> any (`toCheckName1` s) s0s++toCheckName1 :: String -> String -> Bool+toCheckName1 = on checkSepNames $ sepBy '.'++sepBy :: Eq a => a ->[a] -> [[a]]+sepBy x0 xs+	| (t, _ : d) <- span (/= x0) xs = t : sepBy x0 d+	| otherwise = [xs]++checkSepNames :: [String] -> [String] -> Bool+checkSepNames [] [] = True+checkSepNames _ [] = False+checkSepNames [] _ = False+checkSepNames ("*" : ns0) (_ : ns) = checkSepNames ns0 ns+checkSepNames (n0 : ns0) (n : ns) = n0 == n && checkSepNames ns0 ns

@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.PeyoTLS.TChan.Client (+	-- * Basic+	open, open',+	-- * Cipher Suite+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	-- * Others+	ValidateHandle(..), CertSecretKey(..) ) where++import Control.Applicative+import "monads-tf" Control.Monad.State+import Control.Monad.Trans.Control+import Control.Monad.Base+import Control.Concurrent+import Control.Concurrent.STM+import Data.Word+import Data.HandleLike+import Data.X509+import Data.X509.CertificateStore+import Network.PeyoTLS.Client.Body hiding (open, open')+import qualified Network.PeyoTLS.Client.Body as C+import Network.PeyoTLS.Run.Crypto+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC+import qualified Codec.Bytable.BigEndian as B++open' :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => h ->+	String -> [CipherSuite] -> [(CertSecretKey, CertificateChain)] ->+	CertificateStore -> g ->+	HandleMonad h (TChan BSC.ByteString, TChan BSC.ByteString)+open' h dn cs kc ca g = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	((k, _ns), g') <- (`run'` g) $ C.open' h dn cs kc ca+	liftBase $ putStrLn ""+	let	rk = kRKey k+		rmk = kRMKey k+		wk = kWKey k+		wmk = kWMKey k+		CipherSuite _ rcs = kRCSuite k+		CipherSuite _ wcs = kWCSuite k+	_ <- liftBaseDiscard forkIO . forever . (`runStateT` (g', 1)) $ do+		wpln <- liftBase . atomically $ readTChan otc+		(g0, sn) <- get+		let	hs = case wcs of+				AES_128_CBC_SHA -> sha1+				AES_128_CBC_SHA256 -> sha256+				_ -> error "Network.PeyoTLS.TChan.Client.open': bad"+			(wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0+		put (g1, succ sn)+		lift $ hlPut h "\ETB\ETX\ETX"+		lift $ hlPut h+			. (B.encode :: Word16 -> BSC.ByteString) . fromIntegral+			$ BSC.length wenc+		lift $ hlPut h wenc+	_ <- liftBaseDiscard forkIO . forever . (`runStateT` 1) $ do+		sn <- get+		modify succ+		pre <- lift $ hlGet h 3+		liftBase $ print pre+		Right n <- B.decode <$> lift (hlGet h 2)+		enc <- lift $ hlGet h n+		liftBase $ print enc+		let	hs = case rcs of+				AES_128_CBC_SHA -> sha1+				AES_128_CBC_SHA256 -> sha256+				_ -> error "Network.PeyoTLS.TChan.Client.open': bad"+			Right pln = decrypt hs rk rmk sn pre enc+		liftBase $ putStrLn ""+		liftBase . atomically $ writeTChan inc pln+	return (inc, otc)++open :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => h ->+	[CipherSuite] -> [(CertSecretKey, CertificateChain)] ->+	CertificateStore -> g ->+	HandleMonad h (String -> Bool, (TChan BSC.ByteString, TChan BSC.ByteString))+open h cs kc ca g = do+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	((k, ns), g') <- (`run'` g) $ C.open h cs kc ca+	liftBase $ putStrLn ""+	let	rk = kRKey k+		rmk = kRMKey k+		wk = kWKey k+		wmk = kWMKey k+		CipherSuite _ rcs = kRCSuite k+		CipherSuite _ wcs = kWCSuite k+	_ <- liftBaseDiscard forkIO . (`evalStateT` (g', 1)) . forever $ do+		wpln <- liftBase . atomically $ readTChan otc+		(g0, sn) <- get+		let	hs = case wcs of+				AES_128_CBC_SHA -> sha1+				AES_128_CBC_SHA256 -> sha256+				_ -> error "Network.PeyoTLS.TChan.Client.open': bad"+			(wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0+		put (g1, succ sn)+		lift $ hlPut h "\ETB\ETX\ETX"+		lift $ hlPut h+			. (B.encode :: Word16 -> BSC.ByteString) . fromIntegral+			$ BSC.length wenc+		lift $ hlPut h wenc+	_ <- liftBaseDiscard forkIO . (`evalStateT` 1) . forever $ do+		sn <- get+		modify succ+		pre <- lift $ hlGet h 3+		liftBase $ print pre+		Right n <- B.decode <$> lift (hlGet h 2)+		enc <- lift $ hlGet h n+		liftBase $ print enc+		let	hs = case rcs of+				AES_128_CBC_SHA -> sha1+				AES_128_CBC_SHA256 -> sha256+				_ -> error "Network.PeyoTLS.TChan.Client.open': bad"+			Right pln = decrypt hs rk rmk sn pre enc+		liftBase $ putStrLn ""+		liftBase . atomically $ writeTChan inc pln+	return (toCheckName ns, (inc, otc))

@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, PackageImports #-}++module Network.PeyoTLS.TChan.Server (+	-- * Basic+	open,+	-- * Cipher Suite+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	-- * Others+	ValidateHandle(..), CertSecretKey(..) ) where++import Control.Applicative+import "monads-tf" Control.Monad.State+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Concurrent+import Control.Concurrent.STM+import Data.Word+import Data.HandleLike+import Data.X509+import Data.X509.CertificateStore+import Network.PeyoTLS.Server.Body hiding (open)+import qualified Network.PeyoTLS.Server.Body as S+import Network.PeyoTLS.Run.Crypto+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Codec.Bytable.BigEndian as B++open :: (CPRG g, ValidateHandle h, MonadBaseControl IO (HandleMonad h)) =>+	h -> [CipherSuite] -> [(CertSecretKey, CertificateChain)] ->+	Maybe CertificateStore -> g ->+	HandleMonad h (+		Maybe (String -> Bool),+		(TChan BSC.ByteString, TChan BSC.ByteString))+open h cs kcs ca g = do+			inc <- liftBase $ atomically newTChan+			otc <- liftBase $ atomically newTChan+			((k, ns), g') <- (`run'` g) $ do+				p <- S.open h cs kcs ca+				hlFlush p+			let	rk = kRKey k+				rmk = kRMKey k+				wk = kWKey k+				wmk = kWMKey k+			_ <- liftBaseDiscard forkIO+				. (`evalStateT` 1) . forever $ do+				sn <- get+				modify succ+				liftBase $ putStrLn $ "sn = " ++ show sn+				pre <- lift $ hlGet h 3+				when (BSC.null pre) $+					lift (hlClose h) >> error "bad"+				liftBase $ print pre+				Right n <- B.decode <$> lift (hlGet h 2)+				liftBase $ print n+				renc <- lift $ hlGet h n+				let Right rpln = decrypt sha1 rk rmk sn pre renc+				liftBase $ do+					BS.putStr rpln+					atomically $ writeTChan inc rpln++			_ <- liftBaseDiscard forkIO+				. (`evalStateT` (1, g')) . forever $ do+				(sn, g0) <- get+				wpln <- liftBase . atomically $ readTChan otc+				let	(wenc, g1) =+						encrypt sha1 wk wmk sn "\ETB\ETX\ETX" wpln g0+				put (succ sn, g1)+				lift $ hlPut h "\ETB\ETX\ETX"+				lift . hlPut h+					. (B.encode :: Word16 -> BSC.ByteString)+					. fromIntegral $ BSC.length wenc+				lift $ hlPut h wenc++			return (toCheckName ns, (inc, otc))