peyotls 0.0.0.21 → 0.0.0.22

raw patch · 20 files changed

+657/−649 lines, 20 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/clcertClient.hs +1/−1
• examples/clcertEcdsaClient.hs +2/−2
• examples/clcertServer.hs +1/−1
• examples/debugServer.hs +1/−1
• examples/eccServer.hs +2/−2
• examples/renegServer.hs +1/−1
• examples/simpleServer.hs +1/−1
• peyotls.cabal +16/−10
• src/Network/PeyoTLS/Base.hs +192/−66
• src/Network/PeyoTLS/Certificate.hs +10/−13
• src/Network/PeyoTLS/Client.hs +144/−243
• src/Network/PeyoTLS/Handle.hs +51/−42
• src/Network/PeyoTLS/Monad.hs +12/−4
• src/Network/PeyoTLS/ReadFile.hs +20/−22
• src/Network/PeyoTLS/Run.hs +26/−18
• src/Network/PeyoTLS/Server.hs +121/−203
• src/Network/PeyoTLS/State.hs +46/−11
• src/Network/PeyoTLS/Types.hs +6/−6
• test/testCIRenego.hs +2/−1
• test/testDebug.hs +2/−1

@@ -16,7 +16,7 @@ main = do 	d : _ <- getArgs 	rk <- readKey $ d ++ "/yoshikuni.sample_key"-	rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt"+	rc <- readCertificateChain [d ++ "/yoshikuni.sample_crt"] 	ca <- readCertificateStore [d ++ "/cacert.pem"] 	h <- connectTo "localhost" $ PortNumber 443 	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG

@@ -16,9 +16,9 @@ main = do 	d : _ <- getArgs 	rk <- readKey $ d ++ "/yoshikuni.sample_key"-	rc <- readCertificateChain $ d ++ "/yoshikuni.sample_crt"+	rc <- readCertificateChain [d ++ "/yoshikuni.sample_crt"] 	ek <- readKey $ d ++ "/client_ecdsa.sample_key"-	ec <- readCertificateChain $ d ++ "/client_ecdsa.sample_crt"+	ec <- readCertificateChain [d ++ "/client_ecdsa.sample_crt"] 	ca <- readCertificateStore [d ++ "/cacert.pem"] 	h <- connectTo "localhost" $ PortNumber 443 	g <- cprgCreate <$> createEntropyPool :: IO SystemRNG

@@ -18,7 +18,7 @@ main = do 	d : _ <- getArgs 	k <- readKey $ d ++ "/localhost.sample_key"-	c <- readCertificateChain $ d ++"/localhost.sample_crt"+	c <- readCertificateChain [d ++"/localhost.sample_crt"] 	ca <- readCertificateStore [d ++ "/cacert.pem"] 	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG 	soc <- listenOn $ PortNumber 443

@@ -18,7 +18,7 @@ main = do 	d : _ <- getArgs 	k <- readKey $ d ++ "/localhost.sample_key"-	c <- readCertificateChain $ d ++ "/localhost.sample_crt"+	c <- readCertificateChain [d ++ "/localhost.sample_crt"] 	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG 	soc <- listenOn $ PortNumber 443 	void . (`runStateT` g0) . forever $ do

@@ -29,9 +29,9 @@ main = do 	d : _ <- getArgs 	rk <- readKey $ d ++ "/localhost.sample_key"-	rc <- readCertificateChain $ d ++ "/localhost.sample_crt"+	rc <- readCertificateChain [d ++ "/localhost.sample_crt"] 	ek <- readKey $ d ++ "/localhost_ecdsa.sample_key"-	ec <- readCertificateChain $ d ++ "/localhost_ecdsa.sample_crt"+	ec <- readCertificateChain [d ++ "/localhost_ecdsa.sample_crt"] 	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG 	soc <- listenOn $ PortNumber 443 	void . (`runStateT` g0) . forever $ do

@@ -18,7 +18,7 @@ main = do 	d : _ <- getArgs 	k <- readKey $ d ++ "/localhost.sample_key"-	c <- readCertificateChain $ d ++ "/localhost.sample_crt"+	c <- readCertificateChain [d ++ "/localhost.sample_crt"] 	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG 	soc <- listenOn $ PortNumber 443 	void . (`runStateT` g0) . forever $ do

@@ -18,7 +18,7 @@ main = do 	d : _ <- getArgs 	k <- readKey $ d ++ "/localhost.sample_key"-	c <- readCertificateChain $ d ++ "/localhost.sample_crt"+	c <- readCertificateChain [d ++ "/localhost.sample_crt"] 	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG 	soc <- listenOn $ PortNumber 443 	void . (`runStateT` g0) . forever $ do

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.21+version:	0.0.0.22 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -33,11 +33,15 @@     .     * TLS_ECDHE_ECDSA_WITH_AES_128_CBC_SHA256     .+    implement the following curves+    .+    * SEC p256r1+    .     And support client certificate with the following algorithms.     .-    * RSA (SHA1 or SHA256 depending on the agreed cipher suite)+    * RSA with SHA256     .-    * ECDSA (SHA1 or SHA256 depending on the agreed cipher suite)+    * ECDSA with SHA256     .     And support secure renegotiation (RFC 5746)     .@@ -45,6 +49,8 @@     .     * session resumption (RFC 5077)     .+    * curves other than SEC p256r1+    .     Server sample     .     * file: examples/simpleServer.hs@@ -85,7 +91,7 @@     > main :: IO ()     > main = do     >	k <- readKey "localhost.key"-    >	c <- readCertificateChain "localhost.crt"+    >	c <- readCertificateChain ["localhost.crt"]     >	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG     >	soc <- listenOn $ PortNumber 443     >	void . (`runStateT` g0) . forever $ do@@ -172,7 +178,7 @@     > % diff examples/simpleClient.hs examples/clcertClient.hs     > 15a16,17     > >	rk <- readKey "client_rsa.key"-    > >	rc <- readCertificateChain "client_rsa.crt"+    > >	rc <- readCertificateChain ["client_rsa.crt"]     > 20c22     > <		p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca     > ---@@ -185,7 +191,7 @@     > % diff examples/clcertClient.hs examples/clcertEcdsaClient.hs     > 17a18,19     > >	ek <- readKey "client_ecdsa.key"-    > >	ec <- readCertificateChain "client_ecdsa.crt"+    > >	ec <- readCertificateChain ["client_ecdsa.crt"]     > 22c24     > <		p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(rk, rc)] ca     > ---@@ -210,12 +216,12 @@     > >     > 18,19c29,32     > <       k <- readKey "localhost.key"-    > <       c <- readCertificateChain "localhost.crt"+    > <       c <- readCertificateChain ["localhost.crt"]     > ---     > >       rk <- readKey "localhost.key"-    > >       rc <- readCertificateChain "localhost.crt"+    > >       rc <- readCertificateChain ["localhost.crt"]     > >       ek <- readKey "localhost_ecdsa.key"-    > >       ec <- readCertificateChain "localhost_ecdsa.crt"+    > >       ec <- readCertificateChain ["localhost_ecdsa.crt"]     > 26c39     > <                       p <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]     > ---@@ -274,7 +280,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.21+    tag:	peyotls-0.0.0.22  library     hs-source-dirs:	src

@@ -3,11 +3,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Network.PeyoTLS.Base ( Extension(..),+	makeEcdsaPubKey,+	ClSignPublicKey(..), ClSignSecretKey(..),+	SvSignPublicKey(..), 	PeyotlsM, eRenegoInfo, 	debug, generateKs, blindSign, HM.CertSecretKey(..), isEcdsaKey, isRsaKey, 	HM.TlsM, HM.run, HM.HandshakeM, HM.execHandshakeM, HM.rerunHandshakeM, 	HM.withRandom, HM.randomByteString,-	HM.TlsHandle, HM.names,+	HM.TlsHandle_, HM.names, 		readHandshake, getChangeCipherSpec, 		writeHandshake, putChangeCipherSpec, 		writeHandshakeNH,@@ -19,7 +22,7 @@ 		CipherSuite(..), KeyEx(..), BulkEnc(..), 		CompMethod(..), HashAlg(..), SignAlg(..), 		HM.getCipherSuite, HM.setCipherSuite,-	CertificateRequest(..), certificateRequest, ClientCertificateType(..), SecretKey(..),+	CertReq(..), certificateRequest, ClientCertificateType(..), SecretKey(..), 	ClientKeyExchange(..), Epms(..), 		HM.generateKeys, 		HM.encryptRsa, HM.decryptRsa, HM.rsaPadding, HM.debugCipherSuite,@@ -27,6 +30,8 @@ 	HM.Side(..), HM.RW(..), finishedHash, 	DhParam(..), dh3072Modp, secp256r1, HM.throwError, 	HM.getClientFinished, HM.getServerFinished,+	checkClientRenego, makeClientRenego,+	checkServerRenego, makeServerRenego, 	Finished(..), 	HM.ContentType(CTAlert, CTHandshake, CTAppData), 	Handshake(..),@@ -34,10 +39,13 @@ 	hlGetRn, hlGetLineRn_, hlGetLineRn, hlGetContentRn_, 	hlGetContentRn, -	HM.getSettings, HM.setSettings,+	HM.getSettings, HM.setSettings, HM.SettingsS,+	getSettingsC, setSettingsC, 	HM.flushAppData_, 	flushAppData, 	HM.pushAdBufH,++	validateAlert, 	) where  import Control.Applicative@@ -66,14 +74,19 @@ import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.Types.PubKey.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Data.X509 as X509+import qualified Data.X509.Validation as X509+import qualified Data.X509.CertificateStore as X509+ import Network.PeyoTLS.Types ( Extension(..), 	Handshake(..), HandshakeItem(..), 	ClientHello(..), ServerHello(..), SessionId(..), 		CipherSuite(..), KeyEx(..), BulkEnc(..), 		CompMethod(..), 	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+	CertReq(..), certificateRequest, ClientCertificateType(..), 		SignAlg(..), HashAlg(..), 	ServerHelloDone(..), ClientKeyExchange(..), Epms(..), 	DigitallySigned(..), Finished(..) )@@ -81,7 +94,7 @@ 	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM, 	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate,-	TlsHandle(..), ContentType(..),+	TlsHandle_(..), ContentType(..), 		names, 		getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, 		tlsGetContentType, tlsGet, tlsPut, tlsPutNH,@@ -95,7 +108,8 @@ 	getServerFinished, setServerFinished, 	resetSequenceNumber, -	getSettings, setSettings,+	getSettings, setSettings, SettingsS,+	getSettingsC, setSettingsC, 	flushAppData_, 	getAdBuf, 	setAdBuf,@@ -182,52 +196,6 @@ encodeContent (CAlert al ad) = (HM.CTAlert, BS.pack [al, ad]) encodeContent (CHandshake hss) = (HM.CTHandshake, B.encode hss) -class SecretKey sk where-	type Blinder sk-	generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)-	sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString-	signatureAlgorithm :: sk -> SignAlg--instance SecretKey RSA.PrivateKey where-	type Blinder RSA.PrivateKey = RSA.Blinder-	generateBlinder sk rng =-		RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk-	sign hs bl sk bs = let-		(h, oid) = first ($ bs) $ case hs of-			Sha1 -> (SHA1.hash,-				ASN1.OID [1, 3, 14, 3, 2, 26])-			Sha256 -> (SHA256.hash,-				ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])-			_ -> error $ "HandshakeBase: " ++-				"not implemented bulk encryption type"-		a = [ASN1.Start ASN1.Sequence,-			ASN1.Start ASN1.Sequence,-				oid, ASN1.Null, ASN1.End ASN1.Sequence,-			ASN1.OctetString h, ASN1.End ASN1.Sequence]-		b = ASN1.encodeASN1' ASN1.DER a-		pd = BS.concat [ "\x00\x01",-			BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ]-		ps = RSA.public_size $ RSA.private_pub sk in-		RSA.dp (Just bl) sk pd-	signatureAlgorithm _ = Rsa--instance SecretKey ECDSA.PrivateKey where-	type Blinder ECDSA.PrivateKey = Integer-	generateBlinder _ rng = let-		(Right bl, rng') = first B.decode $ cprgGenerate 32 rng in-		(bl, rng')-	sign ha bl sk = B.encode .-		(($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)-		where-		(hs, bls) = case ha of-			Sha1 -> (SHA1.hash, 64)-			Sha256 -> (SHA256.hash, 64)-			_ -> error $ "HandshakeBase: " ++-				"not implemented bulk encryption type"-		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk-		x = ECDSA.private_d sk-	signatureAlgorithm _ = Ecdsa- class DhParam b where 	type Secret b 	type Public b@@ -289,9 +257,9 @@ 		HM.Server -> HM.setServerFinished fh 	return fh -instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle h g) where-	type HandleMonad (HM.TlsHandle h g) = HM.TlsM h g-	type DebugLevel (HM.TlsHandle h g) = DebugLevel h+instance (HandleLike h, CPRG g) => HandleLike (HM.TlsHandle_ h g) where+	type HandleMonad (HM.TlsHandle_ h g) = HM.TlsM h g+	type DebugLevel (HM.TlsHandle_ h g) = DebugLevel h 	hlPut = HM.hlPut_ 	hlGet = (.) <$> checkAppData <*> ((fst `liftM`) .) 		. HM.tlsGet__ . (, undefined)@@ -300,13 +268,13 @@ 	hlDebug = HM.hlDebug_ 	hlClose = HM.hlClose_ -checkAppData :: (HandleLike h, CPRG g) => HM.TlsHandle h g ->+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"+		E.throwError "TlsHandle_.checkAppData: EOF" 	(HM.CTHandshake, hs) -> do 		lift . lift $ hlDebug (HM.tlsHandle t) "critical" "renegotiation?\n" 		lift . lift . hlDebug (HM.tlsHandle t) "critical" . BSC.pack@@ -315,20 +283,20 @@ 			. (++ "\n") $ show (B.decode hs :: Either String Handshake) 		return "" 	_ -> do	_ <- HM.tlsPut_ (t, undefined) HM.CTAlert "\2\10"-		E.throwError "TlsHandle.checkAppData: not application data"+		E.throwError "TlsHandle_.checkAppData: not application data" -hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->-	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString+hlGetRn_ :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) ->+	HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString hlGetRn_ rh = (.) <$> checkAppData <*> ((fst `liftM`) .) . HM.tlsGet_ rh 	. (, undefined)  hlGetLineRn_, hlGetContentRn_ :: (HM.ValidateHandle h, CPRG g) =>-	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g -> HM.TlsM h g BS.ByteString+	(HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString hlGetLineRn_ rh = ($) <$> checkAppData <*> HM.tGetLine_ rh hlGetContentRn_ rh = ($) <$> checkAppData <*> HM.tGetContent_ rh -hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle h g -> HM.TlsM h g ()) ->-	HM.TlsHandle h g -> Int -> HM.TlsM h g BS.ByteString+hlGetRn :: (HM.ValidateHandle h, CPRG g) => (HM.TlsHandle_ h g -> HM.TlsM h g ()) ->+	HM.TlsHandle_ h g -> Int -> HM.TlsM h g BS.ByteString hlGetRn rn t n = do 	bf <- HM.getAdBuf t 	if BS.length bf >= n@@ -338,7 +306,7 @@ 	else (bf `BS.append`) `liftM` hlGetRn_ rn t (n - BS.length bf)  hlGetLineRn :: (HM.ValidateHandle h, CPRG g) =>-	(HM.TlsHandle h g -> HM.TlsM h g ()) -> HM.TlsHandle h g ->+	(HM.TlsHandle_ h g -> HM.TlsM h g ()) -> HM.TlsHandle_ h g -> 	HM.TlsM h g BS.ByteString hlGetLineRn rn t = do 	bf <- HM.getAdBuf t@@ -361,8 +329,8 @@ 	_ -> bs  hlGetContentRn :: (HM.ValidateHandle h, CPRG g) =>-	(HM.TlsHandle h g -> HM.TlsM h g ()) ->-	HM.TlsHandle h g -> HM.TlsM h g BS.ByteString+	(HM.TlsHandle_ h g -> HM.TlsM h g ()) ->+	HM.TlsHandle_ h g -> HM.TlsM h g BS.ByteString hlGetContentRn rn t = do 	bf <- HM.getAdBuf t 	if BS.null bf@@ -384,3 +352,161 @@ eRenegoInfo :: Extension -> Maybe BS.ByteString eRenegoInfo (ERenegoInfo ri) = Just ri eRenegoInfo _ = Nothing++checkClientRenego, checkServerRenego ::+	HandleLike h => BS.ByteString -> HM.HandshakeM h g ()+checkClientRenego cf = (cf ==) `liftM` HM.getClientFinished >>= \ok ->+	E.unless ok . HM.throwError HM.ALFatal HM.ADHsFailure $+		"Network.PeyoTLS.Base.checkClientRenego: bad renegotiation"+checkServerRenego ri = do+	cf <- HM.getClientFinished+	sf <- HM.getServerFinished+	E.unless (ri == cf `BS.append` sf) $ HM.throwError+		HM.ALFatal HM.ADHsFailure+		"Network.PeyoTLS.Base.checkServerRenego: bad renegotiation"++makeClientRenego, makeServerRenego :: HandleLike h => HM.HandshakeM h g Extension+makeClientRenego = ERenegoInfo `liftM` HM.getClientFinished+makeServerRenego = ERenegoInfo `liftM`+	(BS.append `liftM` HM.getClientFinished `E.ap` HM.getServerFinished)++validateAlert :: [X509.FailedReason] -> HM.AlertDesc+validateAlert vr+	| X509.UnknownCA `elem` vr = HM.ADUnknownCa+	| X509.Expired `elem` vr = HM.ADCertificateExpired+	| X509.InFuture `elem` vr = HM.ADCertificateExpired+	| otherwise = HM.ADCertificateUnknown++type SettingsC = (+	[CipherSuite],+	[(HM.CertSecretKey, X509.CertificateChain)],+	X509.CertificateStore )++getSettingsC :: HandleLike h => HM.HandshakeM h g SettingsC+getSettingsC = do+	(css, crts, mcs) <- HM.getSettingsC+	case mcs of+		Just cs -> return (css, crts, cs)+		_ -> HM.throwError HM.ALFatal HM.ADInternalError+			"Network.PeyoTLS.Base.getSettingsC"++setSettingsC :: HandleLike h => SettingsC -> HM.HandshakeM h g ()+setSettingsC (css, crts, cs) = HM.setSettingsC (css, crts, Just cs)++moduleName :: String+moduleName = "Network.PeyoTLS.Base"++decodePoint :: BS.ByteString -> ECC.Point+decodePoint s = case BS.uncons s of+	Just (4, p) -> let (x, y) = BS.splitAt 32 p in ECC.Point+		(either error id $ B.decode x)+		(either error id $ B.decode y)+	_ -> error $ moduleName ++ ".decodePoint: not implemented point"++class SvSignPublicKey pk where+	svpAlgorithm :: pk -> SignAlg+	verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool++instance SvSignPublicKey RSA.PublicKey where+	svpAlgorithm _ = Rsa+	verify = rsaVerify++rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool+rsaVerify ha pk sn m = let+	(hs, oid0) = case ha of+		Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26])+		Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])+		_ -> error "not implemented"+	(o, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail+		. BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of+		Right [ASN1.Start ASN1.Sequence,+			ASN1.Start ASN1.Sequence, oid_, ASN1.Null, ASN1.End ASN1.Sequence,+			ASN1.OctetString o_, ASN1.End ASN1.Sequence ] -> (o_, oid_)+		e -> error $ show e in+	oid == oid0 && o == hs m++instance SvSignPublicKey ECDSA.PublicKey where+	svpAlgorithm _ = Ecdsa+	verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode+	verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode+	verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented"++class SecretKey sk where+	type Blinder sk+	generateBlinder :: CPRG g => sk -> g -> (Blinder sk, g)+	sign :: HashAlg -> Blinder sk -> sk -> BS.ByteString -> BS.ByteString+	signatureAlgorithm :: sk -> SignAlg++instance SecretKey RSA.PrivateKey where+	type Blinder RSA.PrivateKey = RSA.Blinder+	generateBlinder sk rng =+		RSA.generateBlinder rng . RSA.public_n $ RSA.private_pub sk+	sign hs bl sk bs = let+		(h, oid) = first ($ bs) $ case hs of+			Sha1 -> (SHA1.hash,+				ASN1.OID [1, 3, 14, 3, 2, 26])+			Sha256 -> (SHA256.hash,+				ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])+			_ -> error $ "HandshakeBase: " +++				"not implemented bulk encryption type"+		a = [ASN1.Start ASN1.Sequence,+			ASN1.Start ASN1.Sequence,+				oid, ASN1.Null, ASN1.End ASN1.Sequence,+			ASN1.OctetString h, ASN1.End ASN1.Sequence]+		b = ASN1.encodeASN1' ASN1.DER a+		pd = BS.concat [ "\x00\x01",+			BS.replicate (ps - 3 - BS.length b) 0xff, "\NUL", b ]+		ps = RSA.public_size $ RSA.private_pub sk in+		RSA.dp (Just bl) sk pd+	signatureAlgorithm _ = Rsa++instance SecretKey ECDSA.PrivateKey where+	type Blinder ECDSA.PrivateKey = Integer+	generateBlinder _ rng = let+		(Right bl, rng') = first B.decode $ cprgGenerate 32 rng in+		(bl, rng')+	sign ha bl sk = B.encode .+		(($) <$> blindSign bl hs sk . generateKs (hs, bls) q x <*> id)+		where+		(hs, bls) = case ha of+			Sha1 -> (SHA1.hash, 64)+			Sha256 -> (SHA256.hash, 64)+			_ -> error $ "HandshakeBase: " +++				"not implemented bulk encryption type"+		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk+		x = ECDSA.private_d sk+	signatureAlgorithm _ = Ecdsa++class ClSignSecretKey sk where+	csSign :: sk -> BS.ByteString -> BS.ByteString+	csAlgorithm :: sk -> (HashAlg, SignAlg)++instance ClSignSecretKey RSA.PrivateKey where+	csSign sk m = let pd = HM.rsaPadding (RSA.private_pub sk) m in RSA.dp Nothing sk pd+	csAlgorithm _ = (Sha256, Rsa)++instance ClSignSecretKey ECDSA.PrivateKey where+	csSign sk m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m+		where+		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk+		x = ECDSA.private_d sk+		enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [+			ASN1.Start ASN1.Sequence,+				ASN1.IntVal r, ASN1.IntVal s,+				ASN1.End ASN1.Sequence]+	csAlgorithm _ = (Sha256, Ecdsa)++class ClSignPublicKey pk where+	cspAlgorithm :: pk -> SignAlg+	csVerify :: pk -> BS.ByteString -> BS.ByteString -> Bool++instance ClSignPublicKey RSA.PublicKey where+	cspAlgorithm _ = Rsa+	csVerify k s h = RSA.ep k s == HM.rsaPadding k h++instance ClSignPublicKey ECDSA.PublicKey where+	cspAlgorithm _ = Ecdsa+	csVerify k = ECDSA.verify id k . either error id . B.decode++makeEcdsaPubKey :: ECC.CurveName -> BS.ByteString -> ECDSA.PublicKey+makeEcdsaPubKey c xy = ECDSA.PublicKey (ECC.getCurveByName c) $ decodePoint xy

@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Network.PeyoTLS.Certificate (-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+	CertReq(..), certificateRequest, ClientCertificateType(..), 	ClientKeyExchange(..), DigitallySigned(..)) where  import Control.Applicative ((<$>), (<*>))@@ -25,7 +25,7 @@ 		. (\(X509.CertificateChainRaw ccr) -> ccr) 		. X509.encodeCertificateChain 		. (\(X509.CertificateChain cs) ->-			X509.CertificateChain $ reverse cs)+			X509.CertificateChain $ cs)  instance B.Parsable X509.CertificateChain where 	parse = do@@ -33,29 +33,26 @@ 			(flip B.list (B.take =<< B.take 3) =<< B.take 3) 		case ecc of 			Right (X509.CertificateChain cs) ->-				return . X509.CertificateChain $ reverse cs+				return . X509.CertificateChain $ cs 			Left (n, err) -> fail $ show n ++ " " ++ err -data CertificateRequest-	= CertificateRequest [ClientCertificateType]-		[(HashAlg, SignAlg)] [X509.DistinguishedName]-	| CertificateRequestRaw BS.ByteString+data CertReq = CertReq [ClientCertificateType] [(HashAlg, SignAlg)] [X509.DistinguishedName] 	deriving Show  certificateRequest :: [ClientCertificateType] -> [(HashAlg, SignAlg)] ->-	X509.CertificateStore -> CertificateRequest-certificateRequest t a = CertificateRequest t a+	X509.CertificateStore -> CertReq+certificateRequest t a = CertReq t a 	. map (X509.certIssuerDN . X509.signedObject . X509.getSigned) 	. X509.listCertificates -instance B.Bytable CertificateRequest where-	encode (CertificateRequest t a n) = BS.concat [+instance B.Bytable CertReq where+	encode (CertReq t a n) = BS.concat [ 		B.addLen w8 $ cmap B.encode t, 		B.addLen w16 . BS.concat $ 			concatMap (\(h, s) -> [B.encode h, B.encode s]) a, 		B.addLen w16 . flip cmap n $ B.addLen w16 . 			ASN1.encodeASN1' ASN1.DER . flip ASN1.toASN1 [] ]-	encode (CertificateRequestRaw bs) = bs+--	encode (CertReq bs) = bs 	decode = B.evalBytableM $ do 		t <- flip B.list (B.take 1) =<< B.take 1 		a <- flip B.list ((,) <$> B.take 1 <*> B.take 1) =<< B.take 2@@ -64,7 +61,7 @@ 			a1 <- either (fail . show) return $ 				ASN1.decodeASN1' ASN1.DER bs 			either (fail . show) (return . fst) $ ASN1.fromASN1 a1-		return $ CertificateRequest t a n+		return $ CertReq t a n  data ClientCertificateType = CTRsaSign | CTEcdsaSign | CTRaw Word8 	deriving (Show, Eq)

@@ -1,200 +1,179 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts,-	PackageImports, ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}  module Network.PeyoTLS.Client (-	PeyotlsM, PeyotlsHandleC,-	TlsM, TlsHandleC,-	run, open, renegotiate, names,+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names, 	CipherSuite(..), KeyEx(..), BulkEnc(..),-	ValidateHandle(..), CertSecretKey ) where+	ValidateHandle(..), CertSecretKey(..) ) where  import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first)-import Control.Monad (when, unless, liftM)+import Control.Monad (when, unless, liftM, ap)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.List (find, intersect) import Data.HandleLike (HandleLike(..)) import System.IO (Handle) import "crypto-random" Crypto.Random (CPRG, SystemRNG) -import qualified "monads-tf" Control.Monad.Error as E-import qualified "monads-tf" Control.Monad.Error.Class as E import qualified Data.ByteString as BS-import qualified Data.ASN1.Types as ASN1-import qualified Data.ASN1.Encoding as ASN1-import qualified Data.ASN1.BinaryEncoding as ASN1 import qualified Data.X509 as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B-import qualified Crypto.Hash.SHA1 as SHA1-import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.PubKey.DH as DH-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.Prim as RSA import qualified Crypto.Types.PubKey.ECC as ECC-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.Base as HB-import Network.PeyoTLS.Base ( flushAppData,-	Extension(..), getClientFinished,-	getSettings, setSettings,-	getClientFinished, getServerFinished,-	PeyotlsM,-	TlsM, run, HandshakeM, execHandshakeM, rerunHandshakeM,-		CertSecretKey(..),-		withRandom, randomByteString,-	TlsHandle,-		readHandshake, getChangeCipherSpec,-		writeHandshake, putChangeCipherSpec,-	ValidateHandle(..), handshakeValidate,-	ServerKeyExEcdhe(..), ServerKeyExDhe(..), ServerHelloDone(..),-	ClientHello(..), ServerHello(..), SessionId(..),+import qualified Network.PeyoTLS.Base as BASE (names)+import Network.PeyoTLS.Base ( debug,+	PeyotlsM, TlsM, run,+		getSettingsC, setSettingsC,+		hlGetRn, hlGetLineRn, hlGetContentRn,+	HandshakeM, execHandshakeM, rerunHandshakeM,+		withRandom, randomByteString, flushAppData,+		AlertLevel(..), AlertDesc(..), throwError,+	ValidateHandle(..), handshakeValidate, validateAlert,+	TlsHandle_, CertSecretKey(..),+		readHandshake, writeHandshake,+		getChangeCipherSpec, putChangeCipherSpec,+	ClientHello(..), ServerHello(..), SessionId(..), eRenegoInfo, 		CipherSuite(..), KeyEx(..), BulkEnc(..), 		CompMethod(..), HashAlg(..), SignAlg(..), 		setCipherSuite,-	CertificateRequest(..), ClientCertificateType(..),-	ClientKeyExchange(..), Epms(..),-		generateKeys, encryptRsa, rsaPadding,-	DigitallySigned(..), handshakeHash, flushCipherSuite,-	Side(..), RW(..), finishedHash,-	DhParam(..), generateKs, blindSign,+		checkServerRenego, makeClientRenego,+	ServerKeyExEcdhe(..), ServerKeyExDhe(..), SvSignPublicKey(..),+	CertReq(..), ClientCertificateType(..),+	ServerHelloDone(..),+	ClientKeyExchange(..), Epms(..), generateKeys, encryptRsa,+	DigitallySigned(..), ClSignSecretKey(..), handshakeHash,+	Side(..), RW(..), finishedHash, flushCipherSuite,+	DhParam(..), makeEcdsaPubKey ) -	hlGetRn, hlGetLineRn, hlGetContentRn,-	)+type PeyotlsHandle = TlsHandle Handle SystemRNG -names :: TlsHandleC h g -> [String]-names = HB.names . tlsHandleC+newtype TlsHandle h g = TlsHandleC { tlsHandleC :: TlsHandle_ 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 (TlsHandleC t) = hlPut t+	hlGet = hlGetRn rehandshake . tlsHandleC+	hlGetLine = hlGetLineRn rehandshake . tlsHandleC+	hlGetContent = hlGetContentRn rehandshake . tlsHandleC+	hlDebug (TlsHandleC t) = hlDebug t+	hlClose (TlsHandleC t) = hlClose t++moduleName :: String+moduleName = "Network.PeyoTLS.Client"++names :: TlsHandle h g -> [String]+names = BASE.names . tlsHandleC+ open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> 	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	TlsM h g (TlsHandleC h g)+	TlsM h g (TlsHandle h g) open h cscl crts ca = (TlsHandleC `liftM`) . execHandshakeM h $ do-	setSettings (cscl, rcrt, ecrt, Just ca)-	cr <- clientHello cscl-	handshake rcrt ecrt ca cr-	where-	rcrt = first rsaKey <$> find (HB.isRsaKey . fst) crts-	ecrt = first ecdsaKey <$> find (HB.isEcdsaKey . fst) crts+	setSettingsC (cscl, crts, ca)+	handshake crts ca =<< clientHello cscl -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleC h g -> TlsM h g ()+renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleC t) = rerunHandshakeM t $ do-	(cscl, rcrt, ecrt, Just ca) <- getSettings-	cr <- clientHello cscl-	HB.debug "critical" ("CLIENT HASH AFTER CLIENTHELLO" :: String)-	HB.debug "critical" =<< handshakeHash-	ne <- flushAppData-	when ne $ handshake rcrt ecrt ca cr+	(cscl, crts, ca) <- getSettingsC+	clientHello cscl >>= \cr ->+		flushAppData >>= flip when (handshake crts ca cr) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ do-	(cscl, rcrt, ecrt, Just ca) <- getSettings-	cr <- clientHello cscl-	handshake rcrt ecrt ca cr--handshake :: (ValidateHandle h, CPRG g) =>-	Maybe (RSA.PrivateKey, X509.CertificateChain) ->-	Maybe (ECDSA.PrivateKey, X509.CertificateChain) ->-	X509.CertificateStore -> BS.ByteString -> HandshakeM h g ()-handshake rcrt ecrt ca cr = do-	(sr, cs@(CipherSuite ke _)) <- serverHello-	setCipherSuite cs-	HB.debug "critical" ("CLIENT HASH AFTER SERVERHELLO" :: String)-	HB.debug "critical" =<< handshakeHash-	case ke of-		RSA -> rsaHandshake cr sr crts ca-		DHE_RSA -> dheHandshake dhType cr sr crts ca-		ECDHE_RSA -> dheHandshake curveType cr sr crts ca-		ECDHE_ECDSA -> dheHandshake curveType cr sr crts ca-		_ -> error "not implemented"-	where-	dhType :: DH.Params; dhType = undefined-	curveType :: ECC.Curve; curveType = undefined-	crts = case (rcrt, ecrt) of-		(Just (rsk, rcc), Just (esk, ecc)) -> [-			(RsaKey rsk, rcc), (EcdsaKey esk, ecc)]-		(Just (rsk, rcc), _) -> [(RsaKey rsk, rcc)]-		(_, Just (esk, ecc)) -> [(EcdsaKey esk, ecc)]-		_ -> []--getRenegoInfo :: Maybe [Extension] -> Maybe BS.ByteString-getRenegoInfo Nothing = Nothing-getRenegoInfo (Just []) = Nothing-getRenegoInfo (Just (ERenegoInfo rn : _)) = Just rn-getRenegoInfo (Just (_ : es)) = getRenegoInfo $ Just es+	(cscl, crts, ca) <- getSettingsC+	handshake crts ca =<< clientHello cscl  clientHello :: (HandleLike h, CPRG g) => 	[CipherSuite] -> HandshakeM h g BS.ByteString clientHello cscl = do 	cr <- randomByteString 32-	cf <- getClientFinished-	writeHandshake . ClientHello (3, 3) cr (SessionId "") cscl-		[CompMethodNull] $ Just [ERenegoInfo cf]+	((>>) <$> writeHandshake <*> debug "low")+		. ClientHello (3, 3) cr (SessionId "") cscl [CompMethodNull]+		. Just . (: []) =<< makeClientRenego 	return cr -serverHello :: (HandleLike h, CPRG g) =>-	HandshakeM h g (BS.ByteString, CipherSuite)+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)+		_ -> \_ _ _ -> throwError ALFatal ADHsFailure $+			moduleName ++ ".handshake: not implemented"++serverHello :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, KeyEx) serverHello = do-	cf <- getClientFinished-	sf <- getServerFinished-	ServerHello _v sr _sid cs _cm e <- readHandshake-	let	Just rn = getRenegoInfo e-		rn0 = cf `BS.append` sf-	unless (rn == rn0) $ E.throwError "Network.PeyoTLS.Client.hello"-	return (sr, cs)+	ServerHello v sr _sid cs@(CipherSuite ke _) cm e <- readHandshake+	case v of+		(3, 3) -> return ()+		_ -> throwError ALFatal ADProtocolVersion $+			moduleName ++ ".serverHello: only TLS 1.2"+	case cm of+		CompMethodNull -> return ()+		_ -> throwError ALFatal ADHsFailure $+			moduleName ++ ".serverHello: only compression method null"+	case listToMaybe . mapMaybe eRenegoInfo $ fromMaybe [] e of+		Just ri -> checkServerRenego ri+		_ -> throwError ALFatal ADInsufficientSecurity $+			moduleName ++ ".serverHello: require secure renegotiation"+	setCipherSuite cs+	return (sr, ke) -rsaHandshake :: (ValidateHandle h, CPRG g) =>- 	BS.ByteString -> BS.ByteString ->+rsaHandshake :: (ValidateHandle h, CPRG g) => (BS.ByteString, BS.ByteString) -> 	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore -> 	HandshakeM h g ()-rsaHandshake cr sr crts ca = do+rsaHandshake rs crts ca = do 	cc@(X509.CertificateChain (c : _)) <- readHandshake 	vr <- handshakeValidate ca cc-	unless (null vr) $ E.throwError "TlsClient.rsaHandshake: validate failure"-	let X509.PubKeyRSA pk =-		X509.certPubKey . X509.signedObject $ X509.getSigned c+	unless (null vr) . throwError ALFatal (validateAlert vr) $+		moduleName ++ ".rsaHandshake: validate failure"+	pk <- case X509.certPubKey . X509.signedObject $ X509.getSigned c of+		X509.PubKeyRSA k -> return k+		_ -> throwError ALFatal ADIllegalParameter $+			moduleName ++ ".rsaHandshake: require RSA public key" 	crt <- clientCertificate crts 	pms <- ("\x03\x03" `BS.append`) `liftM` randomByteString 46-	generateKeys Client (cr, sr) pms+	generateKeys Client rs pms 	writeHandshake . Epms =<< encryptRsa pk pms 	finishHandshake crt -dheHandshake :: (ValidateHandle h, CPRG g, KeyExchangeClass ke, Show (Secret ke),-	Show (Public ke)) =>-	ke -> BS.ByteString -> BS.ByteString ->+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 cr sr crts ca = do+dheHandshake t rs crts ca = do 	cc@(X509.CertificateChain cs) <- readHandshake-	let c = last cs-	case X509.certPubKey . X509.signedObject $ X509.getSigned c of-		X509.PubKeyRSA pk -> succeedHandshake t pk cr sr cc crts ca-		X509.PubKeyECDSA cv pnt ->-			succeedHandshake t (ek cv pnt) cr sr cc crts ca-		_ -> E.throwError "TlsClient.dheHandshake: not implemented"-	where-	ek cv pnt = ECDSA.PublicKey (ECC.getCurveByName cv) (point pnt)-	point s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point-		(either error id $ B.decode x)-		(either error id $ B.decode y)--succeedHandshake ::-	(ValidateHandle h, CPRG g, Verify pk, KeyExchangeClass ke, Show (Secret ke),-		Show (Public ke)) =>-	ke -> pk -> BS.ByteString -> BS.ByteString -> X509.CertificateChain ->-	[(CertSecretKey, X509.CertificateChain)] -> X509.CertificateStore ->-	HandshakeM h g ()-succeedHandshake t pk cr sr cc crts ca = do 	vr <- handshakeValidate ca cc-	unless (null vr) $-		E.throwError "TlsClient.succeedHandshake: validate failure"-	(ps, pv, ha, _sa, sn) <- serverKeyExchange+	unless (null vr) . throwError ALFatal (validateAlert vr) $+		moduleName ++ ".succeed: validate failure"+	case X509.certPubKey . X509.signedObject . X509.getSigned $ head cs of+		X509.PubKeyRSA pk -> succeed t pk rs crts+		X509.PubKeyECDSA cv pt -> succeed t (makeEcdsaPubKey cv pt) rs crts+		_ -> throwError ALFatal ADHsFailure $+			moduleName ++ ".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 (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) $-		E.throwError "TlsClient.succeedHandshake: verify failure"+	unless (sa == svpAlgorithm pk) . throwError ALFatal ADHsFailure $+		pre ++ "sign algorithm unmatch"+	unless (verify ha pk sn $ BS.concat [cr, sr, B.encode ps, B.encode pv]) .+		throwError ALFatal ADDecryptError $ pre ++ "verify failure" 	crt <- clientCertificate crts 	sv <- withRandom $ generateSecret ps-	generateKeys Client (cr, sr) $ calculateShared ps sv pv+	generateKeys Client rs $ calculateShared ps sv pv 	writeHandshake . ClientKeyExchange . B.encode $ calculatePublic ps sv 	finishHandshake crt+	where pre = moduleName ++ ".succeed: "  class (DhParam bs, B.Bytable bs, B.Bytable (Public bs)) => KeyExchangeClass bs where 	serverKeyExchange :: (HandleLike h, CPRG g) => HandshakeM h g@@ -210,123 +189,45 @@ 		ServerKeyExDhe ps pv ha sa sn <- readHandshake 		return (ps, pv, ha, sa, sn) -class Verify pk where-	verify :: HashAlg -> pk -> BS.ByteString -> BS.ByteString -> Bool--instance Verify RSA.PublicKey where-	verify = rsaVerify--rsaVerify :: HashAlg -> RSA.PublicKey -> BS.ByteString -> BS.ByteString -> Bool-rsaVerify ha pk sn m = let-	(hs, oid0) = case ha of-		Sha1 -> (SHA1.hash, ASN1.OID [1, 3, 14, 3, 2, 26])-		Sha256 -> (SHA256.hash, ASN1.OID [2, 16, 840, 1, 101, 3, 4, 2, 1])-		_ -> error "not implemented"-	(o, oid) = case ASN1.decodeASN1' ASN1.DER . BS.tail-		. BS.dropWhile (== 255) . BS.drop 2 $ RSA.ep pk sn of-		Right [ASN1.Start ASN1.Sequence,-			ASN1.Start ASN1.Sequence, oid_, ASN1.Null, ASN1.End ASN1.Sequence,-			ASN1.OctetString o_, ASN1.End ASN1.Sequence ] -> (o_, oid_)-		e -> error $ show e in-	oid == oid0 && o == hs m--instance Verify ECDSA.PublicKey where-	verify Sha1 pk = ECDSA.verify SHA1.hash pk . either error id . B.decode-	verify Sha256 pk = ECDSA.verify SHA256.hash pk . either error id . B.decode-	verify _ _ = error "TlsClient: ECDSA.PublicKey.verify: not implemented"- clientCertificate :: (HandleLike h, CPRG g) => 	[(CertSecretKey, X509.CertificateChain)] -> 	HandshakeM h g (Maybe (CertSecretKey, X509.CertificateChain)) clientCertificate crts = do-	shd <- readHandshake-	case shd of-		Left (CertificateRequest ca hsa dn) -> do-			ServerHelloDone <- readHandshake-			case find (isMatchedCert ca hsa dn) crts of-				Just (sk, rcc) -> do-					writeHandshake rcc-					return $ Just (sk, rcc)-				_ -> E.throwError . E.strMsg $-					"TlsClient.clientCertificate: " ++-						"no certificate"-		Right ServerHelloDone -> return Nothing-		_ -> E.throwError "TlsClient.clientCertificate"+	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+			_ -> throwError ALFatal ADUnknownCa $ moduleName +++				".clientCertificate: no certificate"  isMatchedCert :: [ClientCertificateType] -> [(HashAlg, SignAlg)] -> 	[X509.DistinguishedName] -> (CertSecretKey, X509.CertificateChain) -> Bool isMatchedCert ct hsa dn = (&&) <$> csk . fst <*> ccrt . snd 	where-	csk (RsaKey _) = CTRsaSign `elem` ct || Rsa `elem` map snd hsa-	csk (EcdsaKey _) = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa-	ccrt (X509.CertificateChain cs@(c : _)) =-		cpk pk && not (null $ intersect dn issr)-		where-		obj = X509.signedObject . X509.getSigned-		pk = X509.certPubKey $ obj c-		issr = map (X509.certIssuerDN . obj) cs-	ccrt _ = error "TlsClient.certIsOk: empty certificate chain"-	cpk X509.PubKeyRSA {} = CTRsaSign `elem` ct || Rsa `elem` map snd hsa-	cpk X509.PubKeyECDSA {} = CTEcdsaSign `elem` ct || Ecdsa `elem` map snd hsa-	cpk _ = False+	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) =+		cpk (X509.certPubKey . obj $ head cs) &&+		not (null . intersect dn $ map (X509.certIssuerDN . obj) cs)+	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 crt of-		Just (RsaKey sk, X509.CertificateChain (c : _)) ->-			writeHandshake $ digitallySigned sk (pubKey sk c) hs-		Just (EcdsaKey sk, X509.CertificateChain (c : _)) ->-			writeHandshake $ digitallySigned sk (pubKey sk c) hs+	case fst <$> crt of+		Just (RsaKey sk) -> writeHandshake $+			DigitallySigned (csAlgorithm sk) $ csSign sk hs+		Just (EcdsaKey sk) -> writeHandshake $+			DigitallySigned (csAlgorithm sk) $ csSign sk hs 		_ -> return () 	putChangeCipherSpec >> flushCipherSuite Write-	fc <- finishedHash Client-	writeHandshake fc+	writeHandshake =<< finishedHash Client 	getChangeCipherSpec >> flushCipherSuite Read-	fs <- finishedHash Server-	(fs ==) `liftM` readHandshake >>= flip unless-		(E.throwError "TlsClient.finishHandshake: finished hash failure")-	where-	digitallySigned sk pk hs = DigitallySigned (algorithm sk) $ sign sk pk hs--class SecretKey sk where-	type PubKey sk-	pubKey :: sk -> X509.SignedCertificate -> PubKey sk-	sign :: sk -> PubKey sk -> BS.ByteString -> BS.ByteString-	algorithm :: sk -> (HashAlg, SignAlg)--instance SecretKey RSA.PrivateKey where-	type PubKey RSA.PrivateKey = RSA.PublicKey-	pubKey _ c = case X509.certPubKey . X509.signedObject $ X509.getSigned c of-		X509.PubKeyRSA pk -> pk-		_ -> error "TlsClient: RSA.PrivateKey.pubKey"-	sign sk pk m = let pd = rsaPadding pk m in RSA.dp Nothing sk pd-	algorithm _ = (Sha256, Rsa)--instance SecretKey ECDSA.PrivateKey where-	type PubKey ECDSA.PrivateKey = ()-	pubKey _ _ = ()-	sign sk _ m = enc $ blindSign 0 id sk (generateKs (SHA256.hash, 64) q x m) m-		where-		q = ECC.ecc_n . ECC.common_curve $ ECDSA.private_curve sk-		x = ECDSA.private_d sk-		enc (ECDSA.Signature r s) = ASN1.encodeASN1' ASN1.DER [-			ASN1.Start ASN1.Sequence,-				ASN1.IntVal r, ASN1.IntVal s,-				ASN1.End ASN1.Sequence]-	algorithm _ = (Sha256, Ecdsa)--newtype TlsHandleC h g = TlsHandleC { tlsHandleC :: TlsHandle h g }--instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleC h g) where-	type HandleMonad (TlsHandleC h g) = TlsM h g-	type DebugLevel (TlsHandleC h g) = DebugLevel h-	hlPut (TlsHandleC t) = hlPut t-	hlGet = hlGetRn rehandshake . tlsHandleC-	hlGetLine = hlGetLineRn rehandshake . tlsHandleC-	hlGetContent = hlGetContentRn rehandshake . tlsHandleC-	hlDebug (TlsHandleC t) = hlDebug t-	hlClose (TlsHandleC t) = hlClose t--type PeyotlsHandleC = TlsHandleC Handle SystemRNG+	(==) `liftM` finishedHash Server `ap` readHandshake >>= flip unless+		(throwError ALFatal ADDecryptError $+			moduleName ++ ".finishHandshake: finished hash failure")

@@ -3,7 +3,7 @@ module Network.PeyoTLS.Handle ( 	TlsM, Alert(..), AlertLevel(..), AlertDesc(..), 		run, withRandom, randomByteString,-	TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..),+	TlsHandle_(..), RW(..), Side(..), ContentType(..), CipherSuite(..), 		newHandle, getContentType, tlsGet, tlsPut, generateKeys, 		debugCipherSuite, 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt,@@ -13,8 +13,10 @@ 	getClientFinishedT, setClientFinishedT, 	getServerFinishedT, setServerFinishedT, +	Settings,+	getSettingsT, setSettingsT, 	getInitSetT, setInitSetT,-	InitialSettings,+	SettingsS,  	resetSequenceNumber, 	tlsGet_,@@ -54,20 +56,21 @@ 	PartnerId, newPartnerId, Keys(..), 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished,-	InitialSettings,+	Settings, getSettings, setSettings,+	SettingsS, 	getInitSet, setInitSet, 	CertSecretKey(..), 	) import qualified Network.PeyoTLS.Crypto as CT ( 	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash ) -data TlsHandle h g = TlsHandle {+data TlsHandle_ h g = TlsHandle_ { 	clientId :: PartnerId, 	tlsHandle :: h, 	names :: [String] } 	deriving Show -type HandleHash h g = (TlsHandle h g, SHA256.Ctx)+type HandleHash h g = (TlsHandle_ h g, SHA256.Ctx)  data Side = Server | Client deriving (Show, Eq) @@ -78,15 +81,15 @@ 		Right r -> return r 		Left a -> error $ show a -newHandle :: HandleLike h => h -> TlsM h g (TlsHandle h g)+newHandle :: HandleLike h => h -> TlsM h g (TlsHandle_ h g) newHandle h = do 	s <- get 	let (i, s') = newPartnerId s 	put s'-	return TlsHandle {+	return TlsHandle_ { 		clientId = i, tlsHandle = h, names = [] } -getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType+getContentType :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g ContentType getContentType t = do 	ct <- fst `liftM` getBuf (clientId t) 	(\gt -> case ct of CTNull -> gt; _ -> return ct) $ do@@ -95,7 +98,7 @@ 		return ct'  flushAppData :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (BS.ByteString, Bool)+	TlsHandle_ h g -> TlsM h g (BS.ByteString, Bool) flushAppData t = do 	ct <- getContentType t 	case ct of@@ -123,13 +126,13 @@ 			| otherwise -> updateHash hh bs 		_ -> return hh -tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->+tlsGet_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) -> 	HandleHash h g -> Int -> 	TlsM h g ((ContentType, BS.ByteString), HandleHash h g) tlsGet_ rn hh@(t, _) n = (, hh) `liftM` buffered_ rn t n  buffered :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+	TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered t n = do 	(ct, b) <- getBuf $ clientId t; let rl = n - BS.length b 	if rl <= 0@@ -144,8 +147,8 @@ 		setBuf (clientId t) (ct', b') 		second (b `BS.append`) `liftM` buffered t rl -buffered_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->-	TlsHandle h g -> Int -> TlsM h g (ContentType, BS.ByteString)+buffered_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) ->+	TlsHandle_ h g -> Int -> TlsM h g (ContentType, BS.ByteString) buffered_ rn t n = do 	ct0 <- getContentType t 	case ct0 of@@ -161,7 +164,7 @@ 				second (b `BS.append`) `liftM` buffered_ rn t rl  splitRetBuf :: HandleLike h =>-	TlsHandle h g -> Int -> ContentType -> BS.ByteString ->+	TlsHandle_ h g -> Int -> ContentType -> BS.ByteString -> 	TlsM h g (ContentType, BS.ByteString) splitRetBuf t n ct b = do 	let (ret, b') = BS.splitAt n b@@ -169,33 +172,33 @@ 	return (ct, ret)  getWholeWithCt :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+	TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) getWholeWithCt t = do 	flush t 	ct <- (either (throwError . strMsg) return . B.decode) =<< read t 1 	[_vmj, _vmn] <- BS.unpack `liftM` read t 2 	e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2-	when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null"+	when (BS.null e) $ throwError "TlsHandle_.getWholeWithCt: e is null" 	p <- decrypt t ct e 	thlDebug (tlsHandle t) "medium" . BSC.pack . (++ ": ") $ show ct 	thlDebug (tlsHandle t) "medium" . BSC.pack . (++  "\n") . show $ BS.head p 	thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p 	return (ct, p) -read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString+read :: (HandleLike h, CPRG g) => TlsHandle_ h g -> Int -> TlsM h g BS.ByteString read t n = do 	r <- thlGet (tlsHandle t) n 	unless (BS.length r == n) . throwError . strMsg $-		"TlsHandle.read: can't read " ++ show (BS.length r) ++ " " ++ show n+		"TlsHandle_.read: can't read " ++ show (BS.length r) ++ " " ++ show n 	return r  decrypt :: HandleLike h =>-	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+	TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt t ct e = do 	ks <- getKeys $ clientId t 	decrypt_ t ks ct e -decrypt_ :: HandleLike h => TlsHandle h g ->+decrypt_ :: HandleLike h => TlsHandle_ h g -> 	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString decrypt_ _ Keys{ kReadCS = CipherSuite _ BE_NULL } _ e = return e decrypt_ t ks ct e = do@@ -206,7 +209,7 @@ 	hs <- case be of 		AES_128_CBC_SHA -> return CT.hashSha1 		AES_128_CBC_SHA256 -> return CT.hashSha256-		_ -> throwError "TlsHandle.decrypt: not implement bulk encryption"+		_ -> throwError "TlsHandle_.decrypt: not implement bulk encryption" 	either (throwError . strMsg) return $ 		CT.decrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") e @@ -223,7 +226,7 @@ 		(CTHandshake, True) -> updateHash hh p 		_ -> return hh -flush :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ()+flush :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g () flush t = do 	(bct, bp) <- getWBuf $ clientId t 	setWBuf (clientId t) (CTNull, "")@@ -233,12 +236,12 @@ 			B.encode bct, "\x03\x03", B.addLen (undefined :: Word16) e ]  encrypt :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString+	TlsHandle_ h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt t ct p = do 	ks <- getKeys $ clientId t 	encrypt_ t ks ct p -encrypt_ :: (HandleLike h, CPRG g) => TlsHandle h g ->+encrypt_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> 	Keys -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString encrypt_ _ Keys{ kWriteCS = CipherSuite _ BE_NULL } _ p = return p encrypt_ t ks ct p = do@@ -249,14 +252,14 @@ 	hs <- case be of 		AES_128_CBC_SHA -> return CT.hashSha1 		AES_128_CBC_SHA256 -> return CT.hashSha256-		_ -> throwError "TlsHandle.encrypt: not implemented bulk encryption"+		_ -> throwError "TlsHandle_.encrypt: not implemented bulk encryption" 	withRandom $ CT.encrypt hs wk mk sn (B.encode ct `BS.append` "\x03\x03") p  updateHash :: 	HandleLike h => HandleHash h g -> BS.ByteString -> TlsM h g (HandleHash h g) updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs) -updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64+updateSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g Word64 updateSequenceNumber t rw = do 	ks <- getKeys $ clientId t 	(sn, cs) <- case rw of@@ -269,12 +272,12 @@ 			Write -> succWriteSn $ clientId t 	return sn -resetSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g ()+resetSequenceNumber :: HandleLike h => TlsHandle_ h g -> RW -> TlsM h g () resetSequenceNumber t rw = case rw of 	Read -> resetReadSn $ clientId t 	Write -> resetWriteSn $ clientId t -generateKeys :: HandleLike h => TlsHandle h g -> Side -> CipherSuite ->+generateKeys :: HandleLike h => TlsHandle_ h g -> Side -> CipherSuite -> 	BS.ByteString -> BS.ByteString -> BS.ByteString -> TlsM h g Keys generateKeys t p cs cr sr pms = do 	let CipherSuite _ be = cs@@ -304,7 +307,7 @@ 	Read -> flushCipherSuiteRead 	Write -> flushCipherSuiteWrite -debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g ()+debugCipherSuite :: HandleLike h => TlsHandle_ h g -> String -> TlsM h g () debugCipherSuite t a = do 	k <- getKeys $ clientId t 	thlDebug (tlsHandle t) "high" . BSC.pack@@ -321,19 +324,19 @@ 	sha256 <- handshakeHash (t, ctx) 	return $ CT.finishedHash (partner == Client) ms sha256 -hlPut_ :: (HandleLike h, CPRG g) => TlsHandle h g -> BS.ByteString -> TlsM h g ()+hlPut_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> BS.ByteString -> TlsM h g () hlPut_ = ((>> return ()) .) . flip (tlsPut True) CTAppData . (, undefined)  hlDebug_ :: HandleLike h =>-	TlsHandle h g -> DebugLevel h -> BS.ByteString -> TlsM h g ()+	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_ :: (HandleLike h, CPRG g) => TlsHandle_ h g -> TlsM h g () hlClose_ t = tlsPut True (t, undefined) CTAlert "\SOH\NUL" >> 	flush t >> thlClose (tlsHandle t)  tGetLine :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+	TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetLine t = do 	(bct, bp) <- getBuf $ clientId t 	case splitLine bp of@@ -342,8 +345,8 @@ 			setBuf (clientId t) cp 			second (bp `BS.append`) `liftM` tGetLine t -tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle h g -> TlsM h g ()) ->-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+tGetLine_ :: (HandleLike h, CPRG g) => (TlsHandle_ h g -> TlsM h g ()) ->+	TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetLine_ rn t = do 	ct <- getContentType t 	case ct of@@ -372,30 +375,36 @@ 	_ -> Nothing  tGetContent :: (HandleLike h, CPRG g) =>-	TlsHandle h g -> TlsM h g (ContentType, BS.ByteString)+	TlsHandle_ h g -> TlsM h g (ContentType, BS.ByteString) tGetContent t = do 	bcp@(_, bp) <- getBuf $ clientId t 	if BS.null bp then getWholeWithCt t else 		setBuf (clientId t) (CTNull, BS.empty) >> return bcp  getClientFinishedT, getServerFinishedT ::-	HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+	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 ()+	HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g () setClientFinishedT = setClientFinished . clientId setServerFinishedT = setServerFinished . clientId -getInitSetT :: HandleLike h => TlsHandle h g -> TlsM h g InitialSettings+getSettingsT :: HandleLike h => TlsHandle_ h g -> TlsM h g Settings+getSettingsT = getSettings . clientId++getInitSetT :: HandleLike h => TlsHandle_ h g -> TlsM h g SettingsS getInitSetT = getInitSet . clientId -setInitSetT :: HandleLike h => TlsHandle h g -> InitialSettings -> TlsM h g ()+setSettingsT :: HandleLike h => TlsHandle_ h g -> Settings -> TlsM h g ()+setSettingsT = setSettings . clientId++setInitSetT :: HandleLike h => TlsHandle_ h g -> SettingsS -> TlsM h g () setInitSetT = setInitSet . clientId -getAdBufT :: HandleLike h => TlsHandle h g -> TlsM h g BS.ByteString+getAdBufT :: HandleLike h => TlsHandle_ h g -> TlsM h g BS.ByteString getAdBufT = getAdBuf . clientId -setAdBufT :: HandleLike h => TlsHandle h g -> BS.ByteString -> TlsM h g ()+setAdBufT :: HandleLike h => TlsHandle_ h g -> BS.ByteString -> TlsM h g () setAdBufT = setAdBuf . clientId

@@ -10,7 +10,8 @@ 		resetReadSn, resetWriteSn, 		getCipherSuiteSt, setCipherSuiteSt, 		flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,-		getInitSet, setInitSet, S.InitialSettings,+		getSettings, setSettings,+		getInitSet, setInitSet, S.SettingsS, S.Settings, 	S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), 	S.ContentType(..), 	S.CipherSuite(..), S.KeyEx(..), S.BulkEnc(..),@@ -41,11 +42,12 @@ 	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite, 	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys,+	getSettings, setSettings, 	getInitSet, setInitSet, 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished, -	InitialSettings,+	SettingsS, Settings, 	CertSecretKey(..), 	) @@ -90,11 +92,17 @@ getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys getKeys = gets . S.getKeys -getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.InitialSettings+getInitSet :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsS getInitSet = gets . S.getInitSet -setInitSet :: HandleLike h => S.PartnerId -> S.InitialSettings -> TlsM h g ()+getSettings :: HandleLike h => S.PartnerId -> TlsM h g S.Settings+getSettings = gets . S.getSettings++setInitSet :: HandleLike h => S.PartnerId -> S.SettingsS -> TlsM h g () setInitSet = (modify .) . S.setInitSet++setSettings :: HandleLike h => S.PartnerId -> S.Settings -> TlsM h g ()+setSettings = (modify .) . S.setSettings  getClientFinished, getServerFinished :: 	HandleLike h => S.PartnerId -> TlsM h g BS.ByteString

@@ -1,11 +1,11 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, TupleSections #-}+{-# LANGUAGE TupleSections #-}  module Network.PeyoTLS.ReadFile ( 	CertSecretKey, readKey, readCertificateChain, readCertificateStore) where  import Control.Applicative ((<$>), (<*>)) import Control.Arrow ((***))-import Control.Monad (unless)+import Control.Monad (unless, forM)  import qualified Data.ByteString as BS import qualified Data.ASN1.Types as ASN1@@ -17,30 +17,26 @@ import qualified Data.X509.File as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B-import Codec.Bytable.BigEndian () import qualified Crypto.PubKey.ECC.Prim as ECC import qualified Crypto.Types.PubKey.ECC as ECC import qualified Crypto.Types.PubKey.ECDSA as ECDSA -import Network.PeyoTLS.CertSecretKey+import Network.PeyoTLS.CertSecretKey (CertSecretKey(..))  readKey :: FilePath -> IO CertSecretKey-readKey fp = do-	rk <- readRsaKey fp-	maybe (readEcdsaKey fp) return rk+readKey fp = maybe (readEcdsaKey fp) return =<< readRsaKey fp  readRsaKey :: FilePath -> IO (Maybe CertSecretKey)-readRsaKey fp = do-	ks <- X509.readKeyFile fp-	case ks of-		[X509.PrivKeyRSA sk] -> return . Just $ RsaKey sk-		_ -> return Nothing -- error "ReadFile.readRsaKey: not single RSA key"+readRsaKey fp = X509.readKeyFile fp >>= \ks -> case ks of+	[X509.PrivKeyRSA sk] -> return . Just $ RsaKey sk+	_ -> return Nothing  readEcdsaKey :: FilePath -> IO CertSecretKey readEcdsaKey = (EcdsaKey . either error id . decodeEcdsaKey <$>) . BS.readFile -readCertificateChain :: FilePath -> IO X509.CertificateChain-readCertificateChain = (X509.CertificateChain <$>) . X509.readSignedObject+readCertificateChain :: [FilePath] -> IO X509.CertificateChain+readCertificateChain fps =+	X509.CertificateChain . concat <$> forM fps X509.readSignedObject  readCertificateStore :: [FilePath] -> IO X509.CertificateStore readCertificateStore =@@ -51,9 +47,11 @@ 	pms <- either (Left . show) return $ PEM.pemParseBS bs 	pm <- fromSinglePem pms 	pmc <- case pm of-		PEM.PEM { PEM.pemName = "EC PRIVATE KEY", PEM.pemHeader = [],+		PEM.PEM {+			PEM.pemName = "EC PRIVATE KEY",+			PEM.pemHeader = [], 			PEM.pemContent = c } -> return c-		_ -> Left $ msgp ++ "bad PEM structure"+		_ -> Left $ pre ++ "bad PEM structure" 	asn <- either (Left . show) return $ ASN1.decodeASN1' ASN1.DER pmc 	(sk, oid, pk) <- case asn of 		[ASN1.Start ASN1.Sequence,@@ -65,20 +63,20 @@ 				ASN1.BitString (ASN1.BitArray _pl p), 				ASN1.End (ASN1.Container ASN1.Context 1), 			ASN1.End ASN1.Sequence] -> (, o, p) <$> B.decode s-		_ -> Left $ msgp ++ "bad ASN.1 structure"-	unless (oid == oidSecp256r1) . Left $ msgp ++ "not implemented curve"+		_ -> Left $ pre ++ "bad ASN.1 structure"+	unless (oid == oidSecp256r1) . Left $ pre ++ "not implemented curve" 	tpk <- case BS.uncons pk of 		Just (4, t) -> return t-		_ -> Left $ msgp ++ "not implemented point format"+		_ -> Left $ pre ++ "not implemented point format" 	(x, y) <- (\(ex, ey) -> (,) <$> ex <*> ey) . 			(B.decode *** B.decode) $ BS.splitAt 32 tpk 	unless (ECC.Point x y == ECC.pointMul secp256r1 sk g) .-		Left $ msgp ++ "the public key not match"+		Left $ pre ++ "the public key not match" 	return $ ECDSA.PrivateKey secp256r1 sk 	where-	msgp = "ReadFile.decodeEcdsaKey: "+	pre = "ReadFile.decodeEcdsaKey: " 	fromSinglePem [x] = return x-	fromSinglePem _ = Left $ msgp ++ "not single PEM"+	fromSinglePem _ = Left $ pre ++ "not single PEM" 	g = ECC.ecc_g $ ECC.common_curve secp256r1 	secp256r1 = ECC.getCurveByName ECC.SEC_p256r1 	oidSecp256r1 = ASN1.OID [1, 2, 840, 10045, 3, 1, 7]

@@ -4,7 +4,7 @@ 	TH.TlsM, TH.run, HandshakeM, execHandshakeM, rerunHandshakeM, 	withRandom, randomByteString, 	ValidateHandle(..), handshakeValidate,-	TH.TlsHandle(..), TH.ContentType(..),+	TH.TlsHandle_(..), TH.ContentType(..), 		getCipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite, 		tlsGetContentType, tlsGet, tlsPut, tlsPutNH, 		generateKeys, encryptRsa, decryptRsa, rsaPadding,@@ -18,7 +18,8 @@  	resetSequenceNumber, -	getSettings, setSettings,+	getSettings, setSettings, TH.SettingsS,+	getSettingsC, setSettingsC, TH.Settings, 	flushAppData_,  	getAdBuf, setAdBuf,@@ -54,7 +55,7 @@ import qualified Network.PeyoTLS.Handle as TH ( 	TlsM, Alert(..), AlertLevel(..), AlertDesc(..), 		run, withRandom, randomByteString,-	TlsHandle(..), ContentType(..),+	TlsHandle_(..), ContentType(..), 		newHandle, getContentType, tlsGet, tlsPut, generateKeys, 		debugCipherSuite, 		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys,@@ -65,7 +66,8 @@  	resetSequenceNumber, -	getInitSetT, setInitSetT, InitialSettings,+	getSettingsT, setSettingsT, Settings,+	getInitSetT, setInitSetT, SettingsS, 	tlsGet_, 	flushAppData, 	getAdBufT,@@ -78,17 +80,17 @@ 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))+	(TH.TlsHandle_ h g -> TH.TlsM h g ()) ->+	(TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx)) tlsGet_ = TH.tlsGet_  tlsGet__ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle h g, SHA256.Ctx))+	(TH.TlsHandle_ h g, SHA256.Ctx) -> Int -> TH.TlsM h g ((TH.ContentType, BS.ByteString), (TH.TlsHandle_ h g, SHA256.Ctx)) tlsGet__ = TH.tlsGet True  tGetLine_, tGetContent_ :: (HandleLike h, CPRG g) =>-	(TH.TlsHandle h g -> TH.TlsM h g ()) ->-	TH.TlsHandle h g -> TH.TlsM h g (TH.ContentType, BS.ByteString)+	(TH.TlsHandle_ h g -> TH.TlsM h g ()) ->+	TH.TlsHandle_ h g -> TH.TlsM h g (TH.ContentType, BS.ByteString) tGetLine_ = TH.tGetLine_  flushAppData_ :: (HandleLike h, CPRG g) => HandshakeM h g (BS.ByteString, Bool)@@ -101,22 +103,22 @@ 		_ -> 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)+	(TH.TlsHandle_ h g, SHA256.Ctx) -> TH.ContentType -> BS.ByteString -> TH.TlsM h g (TH.TlsHandle_ h g, SHA256.Ctx) tlsPut_ = TH.tlsPut True  throwError :: HandleLike h => 	TH.AlertLevel -> TH.AlertDesc -> String -> HandshakeM h g a throwError al ad m = E.throwError $ TH.Alert al ad m -type HandshakeM h g = StateT (TH.TlsHandle h g, SHA256.Ctx) (TH.TlsM h g)+type HandshakeM h g = StateT (TH.TlsHandle_ h g, SHA256.Ctx) (TH.TlsM h g)  execHandshakeM :: HandleLike h =>-	h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle h g)+	h -> HandshakeM h g () -> TH.TlsM h g (TH.TlsHandle_ h g) execHandshakeM h = 	liftM fst . ((, SHA256.init) `liftM` TH.newHandle h >>=) . execStateT  rerunHandshakeM ::-	HandleLike h => TH.TlsHandle h g -> HandshakeM h g a -> TH.TlsM h g a+	HandleLike h => TH.TlsHandle_ h g -> HandshakeM h g a -> TH.TlsM h g a rerunHandshakeM t hm = evalStateT hm (t, SHA256.init)  withRandom :: HandleLike h => (g -> (a, g)) -> HandshakeM h g a@@ -154,7 +156,7 @@ 	X509.CertificateStore -> X509.CertificateChain -> 	HandshakeM h g [X509.FailedReason] handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do-	modify . first $ const t { TH.names = certNames . X509.getCertificate $ last c }+	modify . first $ const t { TH.names = certNames . X509.getCertificate $ head c } 	lift . lift . lift $ validate (TH.tlsHandle t) cs cc  setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()@@ -224,17 +226,23 @@ setClientFinished cf = gets fst >>= lift . flip TH.setClientFinishedT cf setServerFinished cf = gets fst >>= lift . flip TH.setServerFinishedT cf -getSettings :: HandleLike h => HandshakeM h g TH.InitialSettings+getSettings :: HandleLike h => HandshakeM h g TH.SettingsS getSettings = gets fst >>= lift . TH.getInitSetT -setSettings :: HandleLike h => TH.InitialSettings -> HandshakeM h g ()+getSettingsC :: HandleLike h => HandshakeM h g TH.Settings+getSettingsC = gets fst >>= lift . TH.getSettingsT++setSettings :: HandleLike h => TH.SettingsS -> HandshakeM h g () setSettings is = gets fst >>= lift . flip TH.setInitSetT is -getAdBuf :: HandleLike h => TH.TlsHandle h g -> TH.TlsM h g BS.ByteString+setSettingsC :: HandleLike h => TH.Settings -> HandshakeM h g ()+setSettingsC is = gets fst >>= lift . flip TH.setSettingsT is++getAdBuf :: HandleLike h => TH.TlsHandle_ h g -> TH.TlsM h g BS.ByteString getAdBuf = TH.getAdBufT  setAdBuf :: HandleLike h =>-	TH.TlsHandle h g -> BS.ByteString -> TH.TlsM h g ()+	TH.TlsHandle_ h g -> BS.ByteString -> TH.TlsM h g () setAdBuf = TH.setAdBufT  getAdBufH :: HandleLike h => HandshakeM h g BS.ByteString

@@ -1,9 +1,9 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports, TupleSections #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts, PackageImports #-}  module Network.PeyoTLS.Server (-	PeyotlsM, PeyotlsHandleS, TlsM, TlsHandleS, run, open, renegotiate, names,-	CipherSuite(..), KeyEx(..), BulkEnc(..), ValidateHandle(..), CertSecretKey-	) where+	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, run, open, renegotiate, names,+	CipherSuite(..), KeyEx(..), BulkEnc(..),+	ValidateHandle(..), CertSecretKey(..) ) where  import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first)@@ -18,52 +18,44 @@  import qualified Data.ByteString as BS import qualified Data.X509 as X509-import qualified Data.X509.Validation as X509 import qualified Data.X509.CertificateStore as X509 import qualified Codec.Bytable.BigEndian as B import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.Prim as RSA-import qualified Crypto.Types.PubKey.ECC as ECC-import qualified Crypto.Types.PubKey.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Network.PeyoTLS.Base as HB (names)+import qualified Network.PeyoTLS.Base as BASE (names) import Network.PeyoTLS.Base ( 	PeyotlsM, TlsM, run,+		SettingsS, getSettings, setSettings,+		hlGetRn, hlGetLineRn, hlGetContentRn, 	HandshakeM, execHandshakeM, rerunHandshakeM,-		throwError, debug, debugCipherSuite,-		withRandom, randomByteString,-	ValidateHandle(..), handshakeValidate,-	TlsHandle, CertSecretKey(..), isRsaKey, isEcdsaKey,-		readHandshake, getChangeCipherSpec,-		writeHandshake, putChangeCipherSpec,-		writeHandshakeNH,-	AlertLevel(..), AlertDesc(..),-	ClientHello(..), ServerHello(..), SessionId(..), Extension(..),+		withRandom, randomByteString, flushAppData,+		AlertLevel(..), AlertDesc(..), throwError, debugCipherSuite,+	ValidateHandle(..), handshakeValidate, validateAlert,+	TlsHandle_, CertSecretKey(..), isRsaKey, isEcdsaKey,+		readHandshake, writeHandshake, writeHandshakeNH,+		getChangeCipherSpec, putChangeCipherSpec,+	Handshake(HHelloReq),+	ClientHello(..), ServerHello(..), SessionId(..), Extension(..), eRenegoInfo, 		CipherSuite(..), KeyEx(..), BulkEnc(..), 		CompMethod(..), HashAlg(..), SignAlg(..), 		getCipherSuite, setCipherSuite,-		getClientFinished, getServerFinished,-	ServerKeyExchange(..),-	certificateRequest, ClientCertificateType(..), SecretKey(..),+		checkClientRenego, makeServerRenego,+	ServerKeyExchange(..), SecretKey(..),+	certificateRequest, ClientCertificateType(..), 	ServerHelloDone(..),-	ClientKeyExchange(..), Epms(..),-		generateKeys, decryptRsa, rsaPadding,-	DigitallySigned(..), handshakeHash,+	ClientKeyExchange(..), Epms(..), generateKeys, decryptRsa,+	DigitallySigned(..), ClSignPublicKey(..), handshakeHash, 	RW(..), flushCipherSuite, 	Side(..), finishedHash,-	DhParam(..), dh3072Modp, secp256r1,--	Handshake(HHelloReq), eRenegoInfo, getSettings, setSettings, flushAppData,-	hlGetRn, hlGetLineRn, hlGetContentRn )+	DhParam(..), makeEcdsaPubKey, dh3072Modp, secp256r1 ) -type PeyotlsHandleS = TlsHandleS Handle SystemRNG+type PeyotlsHandle = TlsHandle Handle SystemRNG -newtype TlsHandleS h g = TlsHandleS { tlsHandleS :: TlsHandle h g } deriving Show+newtype TlsHandle h g = TlsHandleS { tlsHandleS :: TlsHandle_ h g } deriving Show -instance (ValidateHandle h, CPRG g) => HandleLike (TlsHandleS h g) where-	type HandleMonad (TlsHandleS h g) = TlsM h g-	type DebugLevel (TlsHandleS h g) = DebugLevel h+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 (TlsHandleS t) = hlPut t 	hlGet = hlGetRn rehandshake . tlsHandleS 	hlGetLine = hlGetLineRn rehandshake . tlsHandleS@@ -72,21 +64,19 @@ 	hlClose (TlsHandleS t) = hlClose t  type Version = (Word8, Word8)-type Settings = (-	[CipherSuite],-	Maybe (RSA.PrivateKey, X509.CertificateChain),-	Maybe (ECDSA.PrivateKey, X509.CertificateChain),-	Maybe X509.CertificateStore )  version :: Version version = (3, 3) -names :: TlsHandleS h g -> [String]-names = HB.names . tlsHandleS+moduleName :: String+moduleName = "Network.PeyoTLS.Server" -open :: (ValidateHandle h, CPRG g) => h ->-	[CipherSuite] -> [(CertSecretKey, X509.CertificateChain)] ->-	Maybe X509.CertificateStore -> TlsM h g (TlsHandleS h g)+names :: TlsHandle h g -> [String]+names = BASE.names . 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 $ 	((>>) <$> setSettings <*> handshake) (cssv', 		first rsaKey <$> find (isRsaKey . fst) crts,@@ -101,215 +91,143 @@ 	iscs EMPTY_RENEGOTIATION_INFO = False 	iscs _ = True -renegotiate :: (ValidateHandle h, CPRG g) => TlsHandleS h g -> TlsM h g ()+renegotiate :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g () renegotiate (TlsHandleS t) = rerunHandshakeM t $ writeHandshakeNH HHelloReq >> 		flushAppData >>= flip when (handshake =<< getSettings) -rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle h g -> TlsM h g ()+rehandshake :: (ValidateHandle h, CPRG g) => TlsHandle_ h g -> TlsM h g () rehandshake t = rerunHandshakeM t $ handshake =<< getSettings -handshake :: (ValidateHandle h, CPRG g) => Settings -> HandshakeM h g ()+handshake :: (ValidateHandle h, CPRG g) => SettingsS -> HandshakeM h g () handshake (cssv, rcrt, ecrt, mcs) = do-	(ke, be, cr, cv, rn) <- clientHello cssv-	sr <- serverHello (snd <$> rcrt) (snd <$> ecrt) rn+	(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 		_ -> throwError ALFatal ADInternalError $ 			pre ++ "not implemented bulk encryption type"-	mpk <- ($ mcs) . ($ (cr, sr)) $ case (ke, rcrt, ecrt) of-		(RSA, Just (rsk, _), _) -> rsaKeyExchange rsk cv-		(DHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha dh3072Modp rsk-		(ECDHE_RSA, Just (rsk, _), _) -> dhKeyExchange ha secp256r1 rsk-		(ECDHE_ECDSA, _, Just (esk, _)) -> dhKeyExchange ha secp256r1 esk+	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 		_ -> \_ _ -> throwError ALFatal ADInternalError $ 			pre ++ "no implemented key exchange type or " ++ 				"no applicable certificate files"-	maybe (return ()) certificateVerify mpk+	flip (maybe $ return ()) mpk $ \pk -> case pk of+		X509.PubKeyRSA rpk -> certVerify rpk+		X509.PubKeyECDSA c xy -> certVerify $ makeEcdsaPubKey c xy+		_ -> throwError ALFatal ADUnsupportedCertificate $+			pre ++ "not implement: " ++ show pk 	getChangeCipherSpec >> flushCipherSuite Read-	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok ->-		unless ok . throwError ALFatal ADDecryptError $-			pre ++ "wrong finished hash"+	(==) `liftM` finishedHash Client `ap` readHandshake >>= \ok -> unless ok .+		throwError ALFatal ADDecryptError $ pre ++ "wrong finished hash" 	putChangeCipherSpec >> flushCipherSuite Write 	writeHandshake =<< finishedHash Server-	where pre = "Network.PeyoTLS.Server.handshake: "+	where pre = moduleName ++ ".handshake: "  clientHello :: (HandleLike h, CPRG g) => [CipherSuite] ->-	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version, Bool)+	HandshakeM h g (KeyEx, BulkEnc, BS.ByteString, Version) clientHello cssv = do 	ClientHello cv cr _sid cscl cms me <- readHandshake-	checkRenegotiation cscl me+	checkRenegoInfo cscl me 	unless (cv >= version) . throwError ALFatal ADProtocolVersion $-		pre ++ "client version should 3.3 or more"+		pre ++ "only implement TLS 1.2" 	unless (CompMethodNull `elem` cms) . throwError ALFatal ADDecodeError $ 		pre ++ "compression method NULL must be supported" 	(ke, be) <- case find (`elem` cscl) cssv of 		Just cs@(CipherSuite k b) -> setCipherSuite cs >> return (k, b)-		_ -> throwError ALFatal ADHandshakeFailure $-			pre ++ "no acceptable set of security parameters"-	return (ke, be, cr, cv, True)-	where pre = "Network.PeyoTLS.Server.clientHello: "+		_ -> throwError ALFatal 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: " -checkRenegotiation ::+checkRenegoInfo :: 	HandleLike h => [CipherSuite] -> Maybe [Extension] -> HandshakeM h g ()-checkRenegotiation cscl me = do-	case mcf of-		Just cf -> (cf ==) `liftM` getClientFinished >>= \ok -> unless ok .-			throwError ALFatal ADHandshakeFailure $-				pre ++ "bad renegotiation"-		_ -> throwError ALFatal ADInsufficientSecurity $-			pre ++ "require secure renegotiation"-	where-	pre = "Network.PeyoTLS.Server.checkRenegotiation: "-	mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of+checkRenegoInfo cscl me = (\n -> maybe n checkClientRenego mcf) . throwError+	ALFatal ADInsufficientSecurity $+	moduleName ++ ".checkRenego: require secure renegotiation"+	where mcf = case (EMPTY_RENEGOTIATION_INFO `elem` cscl, me) of 		(True, _) -> Just "" 		(_, Just e) -> listToMaybe $ mapMaybe eRenegoInfo e 		(_, _) -> Nothing  serverHello :: (HandleLike h, CPRG g) =>-	Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> Bool ->+	Maybe X509.CertificateChain -> Maybe X509.CertificateChain -> 	HandshakeM h g BS.ByteString-serverHello rcc ecc rn = do-	cs@(CipherSuite ke _) <- getCipherSuite+serverHello rcc ecc = do+	cs <- getCipherSuite+	ke <- case cs of+		CipherSuite k _ -> return k+		_ -> throwError ALFatal ADInternalError $+			moduleName ++ ".serverHello: never occur" 	sr <- randomByteString 32-	cf <- getClientFinished-	sf <- getServerFinished-	writeHandshake . ServerHello-		version sr (SessionId "") cs CompMethodNull $ if rn-			then Just [ERenegoInfo $ cf `BS.append` sf]-			else Nothing-	debug "critical" ("SERVER HASH AFTER SERVERHELLO" :: String)-	debug "critical" =<< handshakeHash-	writeHandshake $ case (ke, rcc, ecc) of-		(ECDHE_ECDSA, _, Just c) -> c-		(_, Just c, _) -> c-		_ -> error "serverHello"+	writeHandshake+		. ServerHello version sr (SessionId "") cs CompMethodNull+		. Just . (: []) =<< makeServerRenego+	writeHandshake =<< case (ke, rcc, ecc) of+		(ECDHE_ECDSA, _, Just c) -> return c+		(_, Just c, _) -> return c+		_ -> throwError ALFatal ADInternalError $+			moduleName ++ ".serverHello: cert files not match" 	return sr-	{--serverHello _ _ _ _ = throwError ALFatal ADInternalError-	"Network.PeyoTLS.Server.serverHello: never occur"-	-}  rsaKeyExchange :: (ValidateHandle h, CPRG g) => RSA.PrivateKey -> Version -> 	(BS.ByteString, BS.ByteString) -> Maybe X509.CertificateStore -> 	HandshakeM h g (Maybe X509.PubKey)-rsaKeyExchange rsk cv rs mcs = return const-	`ap` requestAndCertificate mcs-	`ap` rsaClientKeyExchange rsk cv rs+rsaKeyExchange sk (vj, vn) rs mcs = const `liftM` reqAndCert mcs `ap` do+	Epms epms <- readHandshake+	generateKeys Server rs =<< mkpms epms `catchError` const+		((BS.cons vj . BS.cons vn) `liftM` randomByteString 46)+	where mkpms epms = do+		pms <- decryptRsa sk epms+		unless (BS.length pms == 48) $ throwError ALFatal ADHsFailure ""+		let [pvj, pvn] = BS.unpack $ BS.take 2 pms+		unless (pvj == vj && pvn == vn) $ throwError ALFatal ADHsFailure ""+		return pms -dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey sk, Show (Secret dp),-		Show (Public dp),+dhKeyExchange :: (ValidateHandle h, CPRG g, SecretKey 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 ssk rs mcs = do+	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-	serverKeyExchange ha dp sv ssk rs-	return const-		`ap` requestAndCertificate mcs-		`ap` dhClientKeyExchange dp sv rs--serverKeyExchange :: (HandleLike h, CPRG g, SecretKey sk,-		DhParam dp, B.Bytable dp, B.Bytable (Public dp)) =>-	HashAlg -> dp -> Secret dp -> sk ->-	(BS.ByteString, BS.ByteString) -> HandshakeM h g ()-serverKeyExchange ha dp sv ssk (cr, sr) = do-	bl <- withRandom $ generateBlinder ssk+	bl <- withRandom $ generateBlinder sk+	let pv = B.encode $ calculatePublic dp sv 	writeHandshake-		. ServerKeyEx edp pv ha (signatureAlgorithm ssk)-		. sign ha bl ssk $ BS.concat [cr, sr, edp, pv]-	where-	edp = B.encode dp-	pv = B.encode $ calculatePublic dp sv+		. ServerKeyEx (B.encode dp) pv ha (signatureAlgorithm sk)+		. sign ha bl sk $ BS.concat [cr, sr, B.encode dp, pv]+	const `liftM` reqAndCert mcs `ap` do+		ClientKeyExchange cke <- readHandshake+		generateKeys Server rs . calculateShared dp sv =<<+			either (throwError ALFatal ADInternalError .+					(moduleName ++) . (".dhKeyExchange: " ++))+				return (B.decode cke) -requestAndCertificate :: (ValidateHandle h, CPRG g) =>+reqAndCert :: (ValidateHandle h, CPRG g) => 	Maybe X509.CertificateStore -> HandshakeM h g (Maybe X509.PubKey)-requestAndCertificate mcs = do+reqAndCert mcs = do 	flip (maybe $ return ()) mcs $ writeHandshake . certificateRequest 		[CTRsaSign, CTEcdsaSign] [(Sha256, Rsa), (Sha256, Ecdsa)]-	writeHandshake ServerHelloDone-	debug "high" ("SERVER HASH AFTER SERVERHELLODONE" :: String)-	debug "high" =<< handshakeHash-	maybe (return Nothing) (liftM Just . clientCertificate) mcs--clientCertificate :: (ValidateHandle h, CPRG g) =>-	X509.CertificateStore -> HandshakeM h g X509.PubKey-clientCertificate cs = do-	cc@(X509.CertificateChain (c : _)) <- readHandshake-	chk cc-	return . X509.certPubKey $ X509.getCertificate c-	where-	chk cc = do-		rs <- handshakeValidate cs cc-		unless (null rs) . throwError ALFatal (selectAlert rs) $-			"TlsServer.clientCertificate: " ++ show rs-	selectAlert rs-		| X509.UnknownCA `elem` rs = ADUnknownCa-		| X509.Expired `elem` rs = ADCertificateExpired-		| X509.InFuture `elem` rs = ADCertificateExpired-		| otherwise = ADCertificateUnknown--rsaClientKeyExchange :: (HandleLike h, CPRG g) => RSA.PrivateKey ->-	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-	mkpms epms = do-		pms <- decryptRsa sk epms-		unless (BS.length pms == 48) $-			throwError ALFatal ADHandshakeFailure ""-		case BS.unpack $ BS.take 2 pms of-			[pvj, pvn] -> unless (pvj == cvj && pvn == cvn) $-				throwError ALFatal ADHandshakeFailure ""-			_ -> error $ "Network.PeyoTLS.Server." ++-				"rsaClientKeyExchange: never occur"-		debug "low" ("PMS" :: String)-		debug "low" pms-		return pms--dhClientKeyExchange :: (HandleLike h, CPRG g, DhParam dp, B.Bytable (Public dp),-	Show (Public dp)) =>-	dp -> Secret dp -> (BS.ByteString, BS.ByteString) -> HandshakeM h g ()-dhClientKeyExchange dp sv rs = do-	ClientKeyExchange cke <- readHandshake-	let Right pv = B.decode cke-	generateKeys Server rs =<< case Right $ calculateShared dp sv pv of-		Left em -> throwError ALFatal ADInternalError $-			"Network.PeyoTLS.Server.dhClientKeyExchange: " ++ em-		Right sh -> return sh+	writeHandshake SHDone+	flip (maybe $ return Nothing) mcs $ liftM Just . \cs -> do+		cc@(X509.CertificateChain (c : _)) <- readHandshake+		vr <- handshakeValidate cs cc+		unless (null vr) . throwError ALFatal (validateAlert vr) $+			moduleName ++ ".reqAndCert: " ++ show vr+		return . X509.certPubKey $ X509.getCertificate c -certificateVerify :: (HandleLike h, CPRG g) => X509.PubKey -> HandshakeM h g ()-certificateVerify (X509.PubKeyRSA pk) = do-	debugCipherSuite "RSA"-	hs0 <- rsaPadding pk `liftM` handshakeHash-	DigitallySigned a s <- readHandshake-	case a of-		(Sha256, Rsa) -> return ()-		_ -> throwError ALFatal ADDecodeError $-			"TlsServer.certificateVEerify: not implement: " ++ show a-	unless (RSA.ep pk s == hs0) $ throwError ALFatal ADDecryptError-		"TlsServer.certificateVerify: client auth failed "-certificateVerify (X509.PubKeyECDSA ECC.SEC_p256r1 xy) = do-	debugCipherSuite "ECDSA"+certVerify :: (HandleLike h, CPRG g, ClSignPublicKey pk) => pk -> HandshakeM h g ()+certVerify pk = do+	debugCipherSuite . show $ cspAlgorithm pk 	hs0 <- handshakeHash 	DigitallySigned a s <- readHandshake 	case a of-		(Sha256, Ecdsa) -> return ()+		(Sha256, sa) | sa == cspAlgorithm pk -> return () 		_ -> throwError ALFatal ADDecodeError $-			"TlsServer.certificateverify: not implement: " ++ show a-	unless (ECDSA.verify id-		(ECDSA.PublicKey secp256r1 $ pnt xy)-		(either error id $ B.decode s) hs0) $ throwError-			ALFatal ADDecryptError-			"TlsServer.certificateverify: client auth failed"-	where-	pnt s = let (x, y) = BS.splitAt 32 $ BS.drop 1 s in ECC.Point-		(either error id $ B.decode x)-		(either error id $ B.decode y)-certificateVerify p = throwError ALFatal ADUnsupportedCertificate $-	"TlsServer.certificateVerify: not implement: " ++ show p+			moduleName ++ ".certVerify: not implement: " ++ show a+	unless (csVerify pk s hs0) . throwError ALFatal ADDecryptError $+		moduleName ++ ".certVerify: client auth failed "

@@ -10,16 +10,20 @@ 	getReadSN, getWriteSN, succReadSN, succWriteSN, resetReadSN, resetWriteSN, 	getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite, 	getKeys, setKeys,+	getSettings, setSettings, 	getInitSet, setInitSet, 	getClientFinished, setClientFinished, 	getServerFinished, setServerFinished, -	InitialSettings,+	SettingsS, Settings, 	CertSecretKey(..), ) where +import Control.Applicative ((<$>))+import Control.Arrow (first) import "monads-tf" Control.Monad.Error.Class (Error(strMsg))-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, maybeToList)+import Data.List (find) import Data.Word (Word8, Word64) import Data.String (IsString(..)) @@ -57,16 +61,39 @@ 		radBuffer = "", 		readSN = 0, writeSN = 0, 		rnClientFinished = "", rnServerFinished = "",-		initialSettings = ([], Nothing, Nothing, Nothing)+		initialSettings = ([], [], Nothing) 		} 	sos = states s -type InitialSettings = (+type SettingsS = ( 	[CipherSuite], 	Maybe (RSA.PrivateKey, X509.CertificateChain), 	Maybe (ECDSA.PrivateKey, X509.CertificateChain),-	Maybe X509.CertificateStore)+	Maybe X509.CertificateStore ) +type Settings = (+	[CipherSuite],+	[(CertSecretKey, X509.CertificateChain)],+	Maybe X509.CertificateStore )++convertSettings :: Settings -> SettingsS+convertSettings (cs, crts, mcs) = (cs,+	first rsaKey <$> find (isRsaKey . fst) crts,+	first ecdsaKey <$> find (isEcdsaKey . fst) crts, mcs)++revertSettings :: SettingsS -> Settings+revertSettings (cs, rcrt, ecrt, mcs) = (cs,+	maybeToList (first RsaKey <$> rcrt) +++	maybeToList (first EcdsaKey <$> ecrt), mcs)++isEcdsaKey :: CertSecretKey -> Bool+isEcdsaKey (EcdsaKey _) = True+isEcdsaKey _ = False++isRsaKey :: CertSecretKey -> Bool+isRsaKey (RsaKey _) = True+isRsaKey _ = False+ data StateOne g = StateOne { 	sKeys :: Keys, 	rBuffer :: (ContentType, BS.ByteString),@@ -76,7 +103,7 @@ 	writeSN :: Word64, 	rnClientFinished :: BS.ByteString, 	rnServerFinished :: BS.ByteString,-	initialSettings :: InitialSettings+	initialSettings :: Settings 	}  getState :: PartnerId -> HandshakeState h g -> StateOne g@@ -136,7 +163,7 @@  data AlertDesc 	= ADCloseNotify            | ADUnexpectedMessage    | ADBadRecordMac-	| ADRecordOverflow         | ADDecompressionFailure | ADHandshakeFailure+	| ADRecordOverflow         | ADDecompressionFailure | ADHsFailure 	| ADUnsupportedCertificate | ADCertificateExpired   | ADCertificateUnknown 	| ADIllegalParameter       | ADUnknownCa            | ADDecodeError 	| ADDecryptError           | ADProtocolVersion      | ADInsufficientSecurity@@ -179,11 +206,19 @@ setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g) setKeys i = modifyState i . \k st -> st { sKeys = k } -getInitSet :: PartnerId -> HandshakeState h g -> InitialSettings-getInitSet i = initialSettings . fromJust' "getInitSet" . lookup i . states+getSettings :: PartnerId -> HandshakeState h g -> Settings+getSettings i = initialSettings . fromJust' "getSettings" . lookup i . states -setInitSet :: PartnerId -> InitialSettings -> Modify (HandshakeState h g)-setInitSet i = modifyState i . \is st -> st { initialSettings = is }+getInitSet :: PartnerId -> HandshakeState h g -> SettingsS+getInitSet i = convertSettings .+	initialSettings . fromJust' "getInitSet" . lookup i . states++setSettings :: PartnerId -> Settings -> Modify (HandshakeState h g)+setSettings i = modifyState i . \is st -> st { initialSettings = is }++setInitSet :: PartnerId -> SettingsS -> Modify (HandshakeState h g)+setInitSet i = modifyState i . \is st -> st+	{ initialSettings = revertSettings is }  getClientFinished, getServerFinished :: 	PartnerId -> HandshakeState h g -> BS.ByteString

@@ -7,7 +7,7 @@ 		CipherSuite(..), KeyEx(..), BulkEnc(..), 		CompMethod(..), 	ServerKeyExchange(..), ServerKeyExDhe(..), ServerKeyExEcdhe(..),-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+	CertReq(..), certificateRequest, ClientCertificateType(..), 		SignAlg(..), HashAlg(..), 	ServerHelloDone(..), ClientKeyExchange(..), Epms(..), 	DigitallySigned(..), Finished(..) ) where@@ -28,14 +28,14 @@ 	CipherSuite(..), KeyEx(..), BulkEnc(..), 	CompMethod(..), HashAlg(..), SignAlg(..) ) import Network.PeyoTLS.Certificate (-	CertificateRequest(..), certificateRequest, ClientCertificateType(..),+	CertReq(..), certificateRequest, ClientCertificateType(..), 	ClientKeyExchange(..), DigitallySigned(..) )  data Handshake 	= HHelloReq 	| HClientHello ClientHello           | HServerHello ServerHello 	| HCertificate X509.CertificateChain | HServerKeyEx BS.ByteString-	| HCertificateReq CertificateRequest | HServerHelloDone+	| HCertificateReq CertReq | HServerHelloDone 	| HCertVerify DigitallySigned        | HClientKeyEx ClientKeyExchange 	| HFinished BS.ByteString            | HRaw Type BS.ByteString 	deriving Show@@ -163,13 +163,13 @@ hasasn :: B.BytableM (HashAlg, SignAlg, BS.ByteString) hasasn = (,,) <$> B.parse <*> B.parse <*> (B.take =<< B.take 2) -instance HandshakeItem CertificateRequest where+instance HandshakeItem CertReq where 	fromHandshake (HCertificateReq cr) = Just cr 	fromHandshake _ = Nothing 	toHandshake = HCertificateReq  instance HandshakeItem ServerHelloDone where-	fromHandshake HServerHelloDone = Just ServerHelloDone+	fromHandshake HServerHelloDone = Just SHDone 	fromHandshake _ = Nothing 	toHandshake _ = HServerHelloDone @@ -205,7 +205,7 @@ 	fromHandshake _ = Nothing 	toHandshake (Finished f) = HFinished f -data ServerHelloDone = ServerHelloDone deriving Show+data ServerHelloDone = SHDone deriving Show  data Type 	= THelloRequest | TClientHello | TServerHello

@@ -32,7 +32,8 @@  ]  randomFrom :: [a] -> IO [a]-randomFrom [] = return []+randomFrom [] = error "bad"+randomFrom [x] = return [x] randomFrom (x : xs) = do 	b <- randomIO 	(if b then (x :) else id) <$> randomFrom xs

@@ -33,7 +33,8 @@  ]  randomFrom :: [a] -> IO [a]-randomFrom [] = return []+randomFrom [] = error "bad"+randomFrom [x] = return [x] randomFrom (x : xs) = do 	b <- randomIO 	(if b then (x :) else id) <$> randomFrom xs