peyotls 0.0.0.12 → 0.0.0.13

raw patch · 7 files changed

+67/−19 lines, 7 filesdep ~handle-likePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: handle-like

API changes (from Hackage documentation)

Files

• examples/debugServer.hs +43/−0
• peyotls.cabal +5/−4
• src/Network/PeyoTLS/HandshakeBase.hs +3/−3
• src/Network/PeyoTLS/HandshakeMonad.hs +1/−1
• src/Network/PeyoTLS/Server.hs +7/−8
• src/Network/PeyoTLS/TlsHandle.hs +4/−1
• test/testClient.hs +4/−2

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++main :: IO ()+main = do+	d : _ <- getArgs+	k <- readKey $ d ++ "/localhost.sample_key"+	c <- readCertificateChain $ d ++ "/localhost.sample_crt"+	g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+	soc <- listenOn $ PortNumber 443+	void . (`runStateT` g0) . forever $ do+		(h, _, _) <- liftIO $ accept soc+		g <- StateT $ return . cprgFork+		liftIO . forkIO . (`run` g) $ do+			p <- open (DebugHandle h $ Just "medium") ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+				Nothing+			doUntil BS.null (hlGetLine p) >>= liftIO . mapM_ BSC.putStrLn+			hlPut p $ BS.concat [+				"HTTP/1.1 200 OK\r\n",+				"Transfer-Encoding: chunked\r\n",+				"Content-Type: text/plain\r\n\r\n",+				"5\r\nHello0\r\n\r\n" ]+			hlClose p++doUntil :: Monad m => (a -> Bool) -> m a -> m [a]+doUntil p rd = rd >>= \x ->+	(if p x then return . (: []) else (`liftM` doUntil p rd) . (:)) x++instance ValidateHandle h => ValidateHandle (DebugHandle h) where+	validate (DebugHandle h _) = validate h

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.12+version:	0.0.0.13 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -252,6 +252,7 @@     examples/clcertEcdsaClient.hs     examples/eccServer.hs     examples/eccClient.hs+    examples/debugServer.hs  data-dir: data data-files:@@ -272,7 +273,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.12+    tag:	peyotls-0.0.0.13  library     hs-source-dirs:	src@@ -297,7 +298,7 @@         cryptohash == 0.11.*,         crypto-pubkey == 0.2.*, crypto-pubkey-types == 0.4.*,         cipher-aes == 0.2.*,-        bytable == 0.1.*, handle-like == 0.0.0.*+        bytable == 0.1.*, handle-like == 0.1.*     ghc-options:	-Wall     extensions:		PatternGuards, DoAndIfThenElse @@ -305,7 +306,7 @@     type: exitcode-stdio-1.0     main-is: testClient.hs     hs-source-dirs: test-    build-depends: peyotls, handle-like == 0.0.0.*,+    build-depends: peyotls, handle-like == 0.1.*,         base == 4.*, bytestring == 0.10.*, network == 2.4.*, stm == 2.4.*,         x509 == 1.4.*, x509-store == 1.4.*, crypto-random == 0.0.*     ghc-options: -Wall

@@ -78,10 +78,10 @@ type PeyotlsM = HM.TlsM Handle SystemRNG type PeyotlsHandle = HM.TlsHandle Handle SystemRNG -debug :: (HandleLike h, Show a) => a -> HM.HandshakeM h g ()-debug x = do+debug :: (HandleLike h, Show a) => DebugLevel h -> a -> HM.HandshakeM h g ()+debug p x = do 	h <- gets $ HM.tlsHandle . fst-	lift . lift . lift . hlDebug h "critical" . BSC.pack . (++ "\n") $ show x+	lift . lift . lift . hlDebug h p . BSC.pack . (++ "\n") $ show x  readHandshake :: (HandleLike h, CPRG g, HandshakeItem hi) => HM.HandshakeM h g hi readHandshake = do

@@ -90,7 +90,7 @@ handshakeValidate cs cc@(X509.CertificateChain c) = gets fst >>= \t -> do 	modify . first $ const t { TH.names = certNames $ X509.getCertificate $ last c } 	lift . lift . lift $ validate (TH.tlsHandle t) cs cc-handshakeValidate _ _ = error "empty certificate chain"+-- handshakeValidate _ _ = error "empty certificate chain"  setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g () setCipherSuite cs = do

@@ -10,7 +10,7 @@ 	ValidateHandle(..), CertSecretKey ) where  import Control.Monad (unless, liftM, ap)-import "monads-tf" Control.Monad.Error (catchError, lift)+import "monads-tf" Control.Monad.Error (catchError) import qualified "monads-tf" Control.Monad.Error as E (throwError) import "monads-tf" Control.Monad.Error.Class (strMsg) import Data.List (find)@@ -19,7 +19,6 @@ import "crypto-random" Crypto.Random (CPRG)  import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC import qualified Data.X509 as X509 import qualified Data.X509.Validation as X509 import qualified Data.X509.CertificateStore as X509@@ -87,8 +86,7 @@ 		AES_128_CBC_SHA256 -> return Sha256 		_ -> E.throwError 			"TlsServer.open: not implemented bulk encryption type"-	lift . lift . lift . hlDebug h "critical" . BSC.pack . (++ "\n") . show .-		RSA.public_size $ RSA.private_pub rsk+--	debug "medium" . RSA.public_size $ RSA.private_pub rsk 	mpk <- (\kep -> kep (cr, sr) mcs) $ case ke of 		RSA -> rsaKeyExchange rsk cv 		DHE_RSA -> dhKeyExchange ha dh3072Modp rsk@@ -130,15 +128,16 @@ clientHello :: (HandleLike h, CPRG g) => 	[CipherSuite] -> HandshakeM h g (CipherSuite, BS.ByteString, Version, Bool) clientHello cssv = do-	ClientHello cv cr _sid cscl cms e <- readHandshake-	debug e+	ch@(ClientHello cv cr _sid cscl cms e) <- readHandshake+	debug "medium" ch+--	debug "medium" e 	let rn = maybe False (ERenegoInfo "" `elem`) e-	debug rn+--	debug "medium" rn 	chk cv cscl cms >> return (merge cssv cscl, cr, cv, rn) 	where 	merge sv cl = case find (`elem` cl) sv of 		Just cs -> cs; _ -> CipherSuite RSA AES_128_CBC_SHA-	chk cv css cms+	chk cv _css cms 		| cv < version = throwError ALFatal ADProtocolVersion $ 			pmsg ++ "client version should 3.3 or more" 			{-

@@ -105,6 +105,9 @@ 	e <- read t =<< either (throwError . strMsg) return . B.decode =<< read t 2 	when (BS.null e) $ throwError "TlsHandle.getWholeWithCt: e is null" 	p <- decrypt t ct e+	thlDebug (tlsHandle t) "high" . BSC.pack . (++ ": ") $ show ct+	thlDebug (tlsHandle t) "high" . BSC.pack . (++  "\n") . show $ BS.head p+	thlDebug (tlsHandle t) "low" . BSC.pack . (++ "\n") $ show p 	return (ct, p)  read :: (HandleLike h, CPRG g) => TlsHandle h g -> Int -> TlsM h g BS.ByteString@@ -230,7 +233,7 @@ debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g () debugCipherSuite t a = do 	k <- getKeys $ clientId t-	thlDebug (tlsHandle t) "moderate" . BSC.pack+	thlDebug (tlsHandle t) "high" . BSC.pack 		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50 		. show $ kCachedCS k 	where lenSpace n str = str ++ replicate (n - length str) ' '

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, PackageImports #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies, PackageImports #-}  import Control.Applicative import Control.Monad@@ -90,7 +90,9 @@ 					return (False, l, x) 		if b	then (bs `BS.append`) <$> hlGet h (n - l) 			else return bs-	hlDebug _ _ = BS.putStr+	hlDebug _ dl+		| dl >= "high" = BS.putStr+		| otherwise = const $ return () 	hlClose _ = return ()  instance ValidateHandle ChanHandle where