peyotls 0.1.4.5 → 0.1.5.5

raw patch · 11 files changed

+114/−69 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• peyotls.cabal +2/−2
• src/Network/PeyoTLS/Base.hs +2/−2
• src/Network/PeyoTLS/Run.hs +3/−2
• src/Network/PeyoTLS/Run/Crypto.hs +1/−1
• src/Network/PeyoTLS/Run/Handle.hs +11/−2
• src/Network/PeyoTLS/Run/Monad.hs +16/−4
• src/Network/PeyoTLS/Run/State.hs +10/−3
• src/Network/PeyoTLS/Server.hs +7/−1
• src/Network/PeyoTLS/Server/Body.hs +6/−2
• src/Network/PeyoTLS/TChan/Client.hs +22/−15
• src/Network/PeyoTLS/TChan/Server.hs +34/−35

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.1.4.5+version:	0.1.5.5 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -281,7 +281,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.1.4.5+    tag:	peyotls-0.1.5.5  library     hs-source-dirs:	src

@@ -10,7 +10,7 @@ 		Alert(..), AlertLevel(..), AlertDesc(..), throw, 		debugCipherSuite, debug, 	ValidateHandle(..), handshakeValidate, validateAlert,-	HandleBase, getNames,+	HandleBase, getNames, getCertificate, 		CertSecretKey(..), isRsaKey, isEcdsaKey, 		readHandshake, writeHandshake, 		CCSpec(..),@@ -71,7 +71,7 @@ import qualified Network.PeyoTLS.Run as RUN (finishedHash, debug) import Network.PeyoTLS.Run ( 	TlsState(..), State1(..), wFlush, Keys(..),-	TlsM, run, run', HandleBase, getNames,+	TlsM, run, run', HandleBase, getNames, getCertificate, 		chGet, hsPut, updateHash, ccsPut, 		adGet, adGetLine, adGetContent, adPut, adDebug, adClose, 	HandshakeM, execHandshakeM, rerunHandshakeM,

@@ -11,7 +11,7 @@ 		H.SettingsS, getSettingsS, setSettingsS, 		getCipherSuite, setCipherSuite, 		getClFinished, getSvFinished, setClFinished, setSvFinished,-		H.getNames,+		H.getNames, H.getCertificate, 		H.RW(..), flushCipherSuite, makeKeys, 		H.Side(..), handshakeHash, finishedHash, 	H.ValidateHandle(..), handshakeValidate, validateAlert,@@ -47,7 +47,7 @@ 		SettingsS, getSettingsS, setSettingsS, 		getClFinished, getSvFinished, setClFinished, setSvFinished, 		makeKeys, setKeys,-		getNames, setNames,+		getNames, setNames, getCertificate, setCertificate, 		Side(..), finishedHash, 		RW(..), flushCipherSuite, 	ValidateHandle(..), tValidate,@@ -176,6 +176,7 @@ 	X509.CertificateChain -> HandshakeM h g [X509.FailedReason] handshakeValidate cs cc@(X509.CertificateChain (c : _)) =  ask >>= \t -> do 	lift . lift . H.setNames t . certNames $ X509.getCertificate c+	lift . lift $ H.setCertificate t c 	lift . lift $ H.tValidate t cs cc handshakeValidate _ _ = error $ modNm ++ ".handshakeValidate: empty cert chain" 

@@ -2,7 +2,7 @@  module Network.PeyoTLS.Run.Crypto ( 	makeKeys, decrypt, encrypt, sha1, sha256,-	Side(..), finishedHash ) where+	Hash, Side(..), finishedHash ) where  import Prelude hiding (splitAt, take) 

@@ -11,7 +11,8 @@ 		M.SettingsC, getSettingsC, setSettingsC, 		M.SettingsS, getSettingsS, setSettingsS, 		getClFinished, getSvFinished, setClFinished, setSvFinished,-		getNames, setNames, makeKeys, setKeys,+		getNames, setNames, getCertificate, setCertificate,+		makeKeys, setKeys, 		M.Side(..), finishedHash, 		M.RW(..), flushCipherSuite, 	ValidateHandle(..), tValidate,@@ -41,7 +42,7 @@ 	PartnerId, newPartner, ContType(..), 		getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn, 		getClFinished, getSvFinished, setClFinished, setSvFinished,-		getNames, setNames,+		getNames, setNames, getCertificate, setCertificate, 	CipherSuite(..), CertSecretKey(..), isRsaKey, isEcdsaKey, 		SettingsC, getSettingsC, setSettingsC, 		SettingsS, getSettingsS, setSettingsS,@@ -244,6 +245,14 @@  setNames :: HandleLike h => HandleBase h g -> [String] -> M.TlsM h g () setNames = M.setNames . pid++getCertificate :: HandleLike h =>+	HandleBase h g -> M.TlsM h g (Maybe X509.SignedCertificate)+getCertificate = M.getCertificate . pid++setCertificate :: HandleLike h =>+	HandleBase h g -> X509.SignedCertificate -> M.TlsM h g ()+setCertificate = M.setCertificate . pid  makeKeys :: HandleLike h => HandleBase h g -> M.Side -> 	BS.ByteString -> BS.ByteString -> BS.ByteString -> M.CipherSuite ->

@@ -9,7 +9,7 @@ 	S.PartnerId, S.newPartner, S.ContType(..), 		getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf, rstSn, 		getClFinished, getSvFinished, setClFinished, setSvFinished,-		getNames, setNames,+		getNames, setNames, getCertificate, setCertificate, 	S.CipherSuite(..), S.CertSecretKey(..), S.isRsaKey, S.isEcdsaKey, 		S.SettingsC, getSettingsC, setSettingsC, 		S.SettingsS, getSettingsS, setSettingsS,@@ -28,11 +28,12 @@ import "crypto-random" Crypto.Random (CPRG)  import qualified Data.ByteString as BS+import qualified Data.X509 as X509 import qualified Codec.Bytable.BigEndian as B  import qualified Network.PeyoTLS.Run.State as S (State1(..), Keys(..), 	TlsState(..), initState, PartnerId, newPartner,-		getGen, setGen, getNames, setNames,+		getGen, setGen, getNames, setNames, getCertificate, setCertificate, 		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, 		getClFinished, getSvFinished, setClFinished, setSvFinished, 	ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,@@ -58,11 +59,14 @@ 	Right r -> return r 	Left a -> error $ show a -run' :: HandleLike h => TlsM h g a -> g -> HandleMonad h ((S.Keys, [String]), g)+run' :: HandleLike h => TlsM h g a -> g ->+	HandleMonad h ((S.Keys, [String], Maybe X509.SignedCertificate), g) run' m g = runStateT (runErrorT m) (S.initState g) >>= \er -> case er of 	(Right _, s) -> return (( 		S.sKeys . snd . head $ S.states s,-		S.sNames . snd . head $ S.states s ), S.gen s)+		S.sNames . snd . head $ S.states s,+		S.sCert . snd . head $ S.states s+		), S.gen s) 	(Left a, _) -> error $ show a  throw :: HandleLike h => AlertLevel -> AlertDesc -> String -> TlsM h g a@@ -168,6 +172,14 @@  setNames :: HandleLike h => S.PartnerId -> [String] -> TlsM h g () setNames = (modify .) . S.setNames++getCertificate :: HandleLike h =>+	S.PartnerId -> TlsM h g (Maybe X509.SignedCertificate)+getCertificate = gets . S.getCertificate++setCertificate :: HandleLike h =>+	S.PartnerId -> X509.SignedCertificate -> TlsM h g ()+setCertificate = (modify .) . S.setCertificate  getSettingsC :: HandleLike h => S.PartnerId -> TlsM h g S.SettingsC getSettingsC i = gets (S.getSettingsC i ) >>= maybe (throw ALFtl ADUnk "...") return

@@ -2,7 +2,7 @@  module Network.PeyoTLS.Run.State ( State1(..), 	TlsState(..), initState, PartnerId, newPartner,-		getGen, setGen, getNames, setNames,+		getGen, setGen, getNames, setNames, getCertificate, setCertificate, 		getRSn, getWSn, rstRSn, rstWSn, sccRSn, sccWSn, 		getClFinished, setClFinished, getSvFinished, setSvFinished, 	ContType(..), getRBuf, getWBuf, getAdBuf, setRBuf, setWBuf, setAdBuf,@@ -57,7 +57,8 @@ 	sKeys :: Keys, readSN :: Word64, writeSN :: Word64, 	rBuffer :: (ContType, BS.ByteString), wBuffer :: (ContType, BS.ByteString), 	adBuffer :: BS.ByteString,-	sNames :: [String] }+	sNames :: [String],+	sCert :: Maybe X509.SignedCertificate }  type Settings = ( 	[CipherSuite], [(CertSecretKey, X509.CertificateChain)],@@ -75,7 +76,7 @@ 		rnClFinished = "", rnSvFinished = "", 		sKeys = nullKeys, readSN = 0, writeSN = 0, 		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""), adBuffer = "",-		sNames = [] }+		sNames = [], sCert = Nothing }  getGen :: TlsState h g -> g getGen = gen@@ -88,6 +89,12 @@  setNames :: PartnerId -> [String] -> Modify (TlsState h g) setNames = setState $ \n st -> st { sNames = n }++getCertificate :: PartnerId -> TlsState h g -> Maybe X509.SignedCertificate+getCertificate = (sCert .) . getState++setCertificate :: PartnerId -> X509.SignedCertificate -> Modify (TlsState h g)+setCertificate = setState $ \c st -> st { sCert = Just c }  getRSn, getWSn :: PartnerId -> TlsState h g -> Word64 getRSn = (readSN .) . getState; getWSn = (writeSN .) . getState

@@ -11,7 +11,7 @@ module Network.PeyoTLS.Server ( 	-- * Basic 	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),-	run, open, getNames,+	run, open, getNames, checkName, getCertificate, 	-- * Renegotiation 	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, 	-- * Cipher Suite@@ -19,4 +19,10 @@ 	-- * Others 	ValidateHandle(..), CertSecretKey(..) ) where +import Data.HandleLike import Network.PeyoTLS.Server.Body++checkName :: HandleLike h => TlsHandle h g -> String -> TlsM h g Bool+checkName t n = do+	ns <- getNames t+	return . maybe False ($ n) $ toCheckName ns

@@ -14,7 +14,7 @@ 	Keys(..), toCheckName, 	-- * Basic 	PeyotlsM, PeyotlsHandle, TlsM, TlsHandle, Alert(..),-	run, run', open, getNames,+	run, run', open, getNames, getCertificate, 	-- * Renegotiation 	renegotiate, setCipherSuites, setKeyCerts, setCertificateStore, 	-- * Cipher Suite@@ -27,6 +27,7 @@ import Control.Monad (when, unless, liftM, ap) import "monads-tf" Control.Monad.Error (catchError) import "monads-tf" Control.Monad.Error.Class (strMsg)+import Data.Maybe (fromJust) import Data.List (find) import Data.Word (Word8) import Data.Function@@ -45,7 +46,7 @@ import qualified Crypto.Types.PubKey.DH as DH import qualified Crypto.Types.PubKey.ECC as ECC -import qualified Network.PeyoTLS.Base as BASE (getNames)+import qualified Network.PeyoTLS.Base as BASE (getNames, getCertificate) import Network.PeyoTLS.Base ( debug, Keys(..), 	PeyotlsM, TlsM, run, run', wFlush, 		SettingsS, getSettingsS, setSettingsS,@@ -97,6 +98,9 @@  getNames :: HandleLike h => TlsHandle h g -> TlsM h g [String] getNames = BASE.getNames . tlsHandleS++getCertificate :: HandleLike h => TlsHandle h g -> TlsM h g X509.SignedCertificate+getCertificate = (fromJust `liftM`) . BASE.getCertificate . tlsHandleS  open :: (ValidateHandle h, CPRG g) => h -> [CipherSuite] -> 	[(CertSecretKey, X509.CertificateChain)] -> Maybe X509.CertificateStore ->

@@ -33,7 +33,7 @@ open' h dn cs kc ca g = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	((k, _ns), g') <- (`run'` g) $ C.open' h dn cs kc ca+	((k, _ns, _), g') <- (`run'` g) $ C.open' h dn cs kc ca 	let	rk = kRKey k 		rmk = kRMKey k 		wk = kWKey k@@ -49,11 +49,11 @@ 				_ -> error "Network.PeyoTLS.TChan.Client.open': bad" 			(wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0 		put (g1, succ sn)-		lift $ hlPut h "\ETB\ETX\ETX"-		lift $ hlPut h-			. (B.encode :: Word16 -> BSC.ByteString) . fromIntegral-			$ BSC.length wenc-		lift $ hlPut h wenc+		lift $ do+			hlPut h "\ETB\ETX\ETX"+			hlPut h . (B.encode :: Word16 -> BSC.ByteString)+				. fromIntegral $ BSC.length wenc+			hlPut h wenc 	_ <- liftBaseDiscard forkIO . (`evalStateT` 1) . forever $ do 		sn <- get 		modify succ@@ -75,7 +75,7 @@ open h cs kc ca g = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan-	((k, ns), g') <- (`run'` g) $ C.open h cs kc ca+	((k, ns, _), g') <- (`run'` g) $ C.open h cs kc ca 	let	rk = kRKey k 		rmk = kRMKey k 		wk = kWKey k@@ -84,18 +84,12 @@ 		CipherSuite _ wcs = kWCSuite k 	_ <- liftBaseDiscard forkIO . (`evalStateT` (g', 1)) . forever $ do 		wpln <- liftBase . atomically $ readTChan otc-		(g0, sn) <- get+--		(g0, sn) <- get 		let	hs = case wcs of 				AES_128_CBC_SHA -> sha1 				AES_128_CBC_SHA256 -> sha256 				_ -> error "Network.PeyoTLS.TChan.Client.open': bad"-			(wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0-		put (g1, succ sn)-		lift $ hlPut h "\ETB\ETX\ETX"-		lift $ hlPut h-			. (B.encode :: Word16 -> BSC.ByteString) . fromIntegral-			$ BSC.length wenc-		lift $ hlPut h wenc+		putEncrypted h hs wk wmk wpln 	_ <- liftBaseDiscard forkIO . (`evalStateT` 1) . forever $ do 		sn <- get 		modify succ@@ -109,3 +103,16 @@ 			Right pln = decrypt hs rk rmk sn pre enc 		liftBase . atomically $ writeTChan inc pln 	return (toCheckName ns, (inc, otc))++putEncrypted :: (HandleLike h, CPRG g) =>+	h -> (Hash, Int) -> BSC.ByteString -> BSC.ByteString+		-> BSC.ByteString -> StateT (g, Word64) (HandleMonad h) ()+putEncrypted h hs wk wmk wpln = do+		(g0, sn) <- get+		let	(wenc, g1) = encrypt hs wk wmk sn "\ETB\ETX\ETX" wpln g0+		put (g1, succ sn)+		lift $ do+			hlPut h "\ETB\ETX\ETX"+			hlPut h . (B.encode :: Word16 -> BSC.ByteString)+				. fromIntegral $ BSC.length wenc+			hlPut h wenc

@@ -23,7 +23,6 @@ import Network.PeyoTLS.Run.Crypto import "crypto-random" Crypto.Random -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Codec.Bytable.BigEndian as B @@ -31,41 +30,41 @@ 	h -> [CipherSuite] -> [(CertSecretKey, CertificateChain)] -> 	Maybe CertificateStore -> g -> 	HandleMonad h (-		Maybe (String -> Bool),+		Maybe (String -> Bool, SignedCertificate), 		(TChan BSC.ByteString, TChan BSC.ByteString)) open h cs kcs ca g = do-			inc <- liftBase $ atomically newTChan-			otc <- liftBase $ atomically newTChan-			((k, ns), g') <- (`run'` g) $ do-				p <- S.open h cs kcs ca-				hlFlush p-			let	rk = kRKey k-				rmk = kRMKey k-				wk = kWKey k-				wmk = kWMKey k-			_ <- liftBaseDiscard forkIO-				. (`evalStateT` 1) . forever $ do-				sn <- get-				modify succ-				pre <- lift $ hlGet h 3-				when (BSC.null pre) $-					lift (hlClose h) >> error "bad"-				Right n <- B.decode <$> lift (hlGet h 2)-				renc <- lift $ hlGet h n-				let Right rpln = decrypt sha1 rk rmk sn pre renc-				liftBase . atomically $ writeTChan inc rpln+	inc <- liftBase $ atomically newTChan+	otc <- liftBase $ atomically newTChan+	((k, ns, crt), g') <- (`run'` g) $ do+		p <- S.open h cs kcs ca+		hlFlush p+	let	rk = kRKey k+		rmk = kRMKey k+		wk = kWKey k+		wmk = kWMKey k+	_ <- liftBaseDiscard forkIO+		. (`evalStateT` 1) . forever $ do+		sn <- get+		modify succ+		pre <- lift $ hlGet h 3+		when (BSC.null pre) $+			lift (hlClose h) >> error "bad"+		Right n <- B.decode <$> lift (hlGet h 2)+		renc <- lift $ hlGet h n+		let Right rpln = decrypt sha1 rk rmk sn pre renc+		liftBase . atomically $ writeTChan inc rpln -			_ <- liftBaseDiscard forkIO-				. (`evalStateT` (1, g')) . forever $ do-				(sn, g0) <- get-				wpln <- liftBase . atomically $ readTChan otc-				let	(wenc, g1) =-						encrypt sha1 wk wmk sn "\ETB\ETX\ETX" wpln g0-				put (succ sn, g1)-				lift $ hlPut h "\ETB\ETX\ETX"-				lift . hlPut h-					. (B.encode :: Word16 -> BSC.ByteString)-					. fromIntegral $ BSC.length wenc-				lift $ hlPut h wenc+	_ <- liftBaseDiscard forkIO+		. (`evalStateT` (1, g')) . forever $ do+		(sn, g0) <- get+		wpln <- liftBase . atomically $ readTChan otc+		let	(wenc, g1) =+				encrypt sha1 wk wmk sn "\ETB\ETX\ETX" wpln g0+		put (succ sn, g1)+		lift $ hlPut h "\ETB\ETX\ETX"+		lift . hlPut h+			. (B.encode :: Word16 -> BSC.ByteString)+			. fromIntegral $ BSC.length wenc+		lift $ hlPut h wenc -			return (toCheckName ns, (inc, otc))+	return ((,) <$> toCheckName ns <*> crt, (inc, otc))