packages feed

peyotls 0.0.0.11 → 0.0.0.12

raw patch · 5 files changed

+104/−35 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

peyotls.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		peyotls-version:	0.0.0.11+version:	0.0.0.12 stability:	Experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -272,7 +272,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/peyotls.git-    tag:	peyotls-0.0.0.11+    tag:	peyotls-0.0.0.12  library     hs-source-dirs:	src
src/Network/PeyoTLS/HandshakeMonad.hs view
@@ -38,7 +38,8 @@ 		run, withRandom, randomByteString, 	TlsHandle(..), ContentType(..), 		newHandle, getContentType, tlsGet, tlsPut, generateKeys,-		cipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+		debugCipherSuite,+		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt, setKeys, 	Side(..), RW(..), finishedHash, handshakeHash, CipherSuite(..) )  throwError :: HandleLike h =>@@ -92,11 +93,14 @@ handshakeValidate _ _ = error "empty certificate chain"  setCipherSuite :: HandleLike h => TH.CipherSuite -> HandshakeM h g ()-setCipherSuite = modify . first . TH.setCipherSuite+setCipherSuite cs = do+	t <- gets fst+	lift $ TH.setCipherSuiteSt (TH.clientId t) cs  flushCipherSuite :: (HandleLike h, CPRG g) => TH.RW -> HandshakeM h g ()-flushCipherSuite p =-	TH.flushCipherSuite p `liftM` gets fst >>= modify . first . const+flushCipherSuite p = do+	t <- gets fst+	lift $ TH.flushCipherSuiteSt p (TH.clientId t)  debugCipherSuite :: HandleLike h => String -> HandshakeM h g () debugCipherSuite m = do t <- gets fst; lift $ TH.debugCipherSuite t m@@ -115,8 +119,10 @@ 	(BS.ByteString, BS.ByteString) -> BS.ByteString -> HandshakeM h g () generateKeys p (cr, sr) pms = do 	t <- gets fst-	k <- lift $ TH.generateKeys p (TH.cipherSuite t) cr sr pms-	modify . first $ const t { TH.keys = k }+	cs <- lift $ TH.getCipherSuiteSt (TH.clientId t)+	k <- lift $ TH.generateKeys p cs cr sr pms+	lift $ TH.setKeys (TH.clientId t) k+--	modify . first $ const t { TH.keys = k }  encryptRsa :: (HandleLike h, CPRG g) => 	RSA.PublicKey -> BS.ByteString -> HandshakeM h g BS.ByteString
src/Network/PeyoTLS/State.hs view
@@ -7,6 +7,8 @@ 	randomGen, setRandomGen, 	getBuf, setBuf, getWBuf, setWBuf, 	getReadSN, getWriteSN, succReadSN, succWriteSN,+	getCipherSuite, setCipherSuite, flushCipherSuiteRead, flushCipherSuiteWrite,+	getKeys, setKeys, ) where  import "monads-tf" Control.Monad.Error.Class (Error(strMsg))@@ -36,14 +38,17 @@ 	where 	i = nextPartnerId s 	so = StateOne {+		sKeys = nullKeys, 		rBuffer = (CTNull, ""), wBuffer = (CTNull, ""), 		readSN = 0, writeSN = 0 } 	sos = states s  data StateOne g = StateOne {+	sKeys :: Keys, 	rBuffer :: (ContentType, BS.ByteString), 	wBuffer :: (ContentType, BS.ByteString),-	readSN :: Word64, writeSN :: Word64 }+	readSN :: Word64,+	writeSN :: Word64 }  getState :: PartnerId -> HandshakeState h g -> StateOne g getState i = fromJust' "getState" . lookup i . states@@ -115,6 +120,28 @@  setBuf :: PartnerId -> (ContentType, BS.ByteString) -> Modify (HandshakeState h g) setBuf i = modifyState i . \bs st -> st { rBuffer = bs }++getCipherSuite :: PartnerId -> HandshakeState h g -> CipherSuite+getCipherSuite i =+	kCachedCS . sKeys . fromJust' "getCipherSuite" . lookup i . states++setCipherSuite :: PartnerId -> CipherSuite -> Modify (HandshakeState h g)+setCipherSuite i = modifyState i . \cs st ->+	st { sKeys = (sKeys st) { kCachedCS = cs } }++getKeys :: PartnerId -> HandshakeState h g -> Keys+getKeys i = sKeys . fromJust' "getKeys" . lookup i . states++setKeys :: PartnerId -> Keys -> Modify (HandshakeState h g)+setKeys i = modifyState i . \k st -> st { sKeys = k }++flushCipherSuiteRead :: PartnerId -> Modify (HandshakeState h g)+flushCipherSuiteRead i = modifyState i $ \st ->+	st { sKeys = (sKeys st) { kReadCS = kCachedCS (sKeys st) } }++flushCipherSuiteWrite :: PartnerId -> Modify (HandshakeState h g)+flushCipherSuiteWrite i = modifyState i $ \st ->+	st { sKeys = (sKeys st) { kWriteCS = kCachedCS (sKeys st) } }  getWBuf :: PartnerId -> HandshakeState h g -> (ContentType, BS.ByteString) getWBuf i = wBuffer . fromJust' "getWriteBuffer" . lookup i . states
src/Network/PeyoTLS/TlsHandle.hs view
@@ -5,7 +5,9 @@ 		run, withRandom, randomByteString, 	TlsHandle(..), RW(..), Side(..), ContentType(..), CipherSuite(..), 		newHandle, getContentType, tlsGet, tlsPut, generateKeys,-		cipherSuite, setCipherSuite, flushCipherSuite, debugCipherSuite,+		debugCipherSuite,+		getCipherSuiteSt, setCipherSuiteSt, flushCipherSuiteSt,+		setKeys, 		handshakeHash, finishedHash ) where  import Prelude hiding (read)@@ -29,15 +31,17 @@ 	TlsM, evalTlsM, initState, thlGet, thlPut, thlClose, thlDebug, 		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn,+		getCipherSuiteSt, setCipherSuiteSt,+		flushCipherSuiteRead, flushCipherSuiteWrite, getKeys, setKeys, 	Alert(..), AlertLevel(..), AlertDesc(..), 	ContentType(..), CipherSuite(..), KeyExchange(..), BulkEncryption(..),-	PartnerId, newPartnerId, Keys(..), nullKeys )+	PartnerId, newPartnerId, Keys(..)) import qualified Network.PeyoTLS.CryptoTools as CT ( 	makeKeys, encrypt, decrypt, hashSha1, hashSha256, finishedHash )  data TlsHandle h g = TlsHandle { 	clientId :: PartnerId,-	tlsHandle :: h, keys :: Keys, names :: [String] }+	tlsHandle :: h, names :: [String] }  type HandleHash h g = (TlsHandle h g, SHA256.Ctx) @@ -56,7 +60,7 @@ 	let (i, s') = newPartnerId s 	put s' 	return TlsHandle {-		clientId = i, tlsHandle = h, keys = nullKeys, names = [] }+		clientId = i, tlsHandle = h, names = [] }  getContentType :: (HandleLike h, CPRG g) => TlsHandle h g -> TlsM h g ContentType getContentType t = do@@ -112,9 +116,14 @@  decrypt :: HandleLike h => 	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-decrypt t _ e-	| Keys{ kReadCS = CipherSuite _ BE_NULL } <- keys t = return e-decrypt t@TlsHandle{ keys = ks } ct e = do+decrypt t ct e = do+	ks <- getKeys $ clientId t+	decrypt_ t ks ct e++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 	let	CipherSuite _ be = kReadCS ks 		wk = kReadKey ks 		mk = kReadMacKey ks@@ -150,9 +159,14 @@  encrypt :: (HandleLike h, CPRG g) => 	TlsHandle h g -> ContentType -> BS.ByteString -> TlsM h g BS.ByteString-encrypt t _ p-	| Keys{ kWriteCS = CipherSuite _ BE_NULL } <- keys t = return p-encrypt t@TlsHandle{ keys = ks } ct p = do+encrypt t ct p = do+	ks <- getKeys $ clientId t+	encrypt_ t ks ct p++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 	let	CipherSuite _ be = kWriteCS ks 		wk = kWriteKey ks 		mk = kWriteMacKey ks@@ -168,7 +182,8 @@ updateHash (th, ctx') bs = return (th, SHA256.update ctx' bs)  updateSequenceNumber :: HandleLike h => TlsHandle h g -> RW -> TlsM h g Word64-updateSequenceNumber t@TlsHandle{ keys = ks } rw = do+updateSequenceNumber t rw = do+	ks <- getKeys $ clientId t 	(sn, cs) <- case rw of 		Read -> (, kReadCS ks) `liftM` getReadSn (clientId t) 		Write -> (, kWriteCS ks) `liftM` getWriteSn (clientId t)@@ -205,23 +220,19 @@ 			kReadMacKey = cwmk, kWriteMacKey = swmk, 			kReadKey = cwk, kWriteKey = swk } -cipherSuite :: TlsHandle h g -> CipherSuite-cipherSuite = kCachedCS . keys--setCipherSuite :: CipherSuite -> TlsHandle h g -> TlsHandle h g-setCipherSuite c t@TlsHandle{ keys = k } = t{ keys = k{ kCachedCS = c } }- data RW = Read | Write deriving Show -flushCipherSuite :: RW -> TlsHandle h g -> TlsHandle h g-flushCipherSuite p t@TlsHandle{ keys = ks } = case p of-	Read -> t{ keys = ks { kReadCS = kCachedCS ks } }-	Write -> t{ keys = ks { kWriteCS = kCachedCS ks } }+flushCipherSuiteSt :: HandleLike h => RW -> PartnerId -> TlsM h g ()+flushCipherSuiteSt p = case p of+	Read -> flushCipherSuiteRead+	Write -> flushCipherSuiteWrite  debugCipherSuite :: HandleLike h => TlsHandle h g -> String -> TlsM h g ()-debugCipherSuite t a = thlDebug (tlsHandle t) "moderate" . BSC.pack-	. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50-	. show . kCachedCS $ keys t+debugCipherSuite t a = do+	k <- getKeys $ clientId t+	thlDebug (tlsHandle t) "moderate" . BSC.pack+		. (++ (" - VERIFY WITH " ++ a ++ "\n")) . lenSpace 50+		. show $ kCachedCS k 	where lenSpace n str = str ++ replicate (n - length str) ' '  handshakeHash :: HandleLike h => HandleHash h g -> TlsM h g BS.ByteString@@ -229,7 +240,7 @@  finishedHash :: HandleLike h => HandleHash h g -> Side -> TlsM h g BS.ByteString finishedHash (t, ctx) partner = do-	let ms = kMasterSecret $ keys t+	ms <- kMasterSecret `liftM` getKeys (clientId t) 	sha256 <- handshakeHash (t, ctx) 	return $ CT.finishedHash (partner == Client) ms sha256 @@ -281,5 +292,9 @@ 	(CTAlert, "\SOH\NUL") -> do 		_ <- tlsPut (t, undefined) CTAlert "\SOH\NUL" 		throwError "TlsHandle.checkAppData: EOF"+	(CTHandshake, hs) -> do+		lift . lift $ hlDebug (tlsHandle t) "critical" "renegotiation?"+		lift . lift $ hlDebug (tlsHandle t) "critical" . BSC.pack $ show hs+		return "" 	_ -> do	_ <- tlsPut (t, undefined) CTAlert "\2\10" 		throwError "TlsHandle.checkAppData: not application data"
src/Network/PeyoTLS/TlsMonad.hs view
@@ -5,6 +5,8 @@ 		thlGet, thlPut, thlClose, thlDebug, thlError, 		withRandom, randomByteString, getBuf, setBuf, getWBuf, setWBuf, 		getReadSn, getWriteSn, succReadSn, succWriteSn,+		getCipherSuiteSt, setCipherSuiteSt,+		flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys, 	S.Alert(..), S.AlertLevel(..), S.AlertDesc(..), 	S.ContentType(..), 	S.CipherSuite(..), S.KeyExchange(..), S.BulkEncryption(..),@@ -26,7 +28,9 @@ 	CipherSuite(..), KeyExchange(..), BulkEncryption(..), 	randomGen, setRandomGen, 	setBuf, getBuf, setWBuf, getWBuf,-	getReadSN, getWriteSN, succReadSN, succWriteSN )+	getReadSN, getWriteSN, succReadSN, succWriteSN,+	getCipherSuite, setCipherSuite,+	flushCipherSuiteRead, flushCipherSuiteWrite, setKeys, getKeys)  type TlsM h g = ErrorT S.Alert (StateT (S.HandshakeState h g) (HandleMonad h)) @@ -47,6 +51,23 @@  succWriteSn, succReadSn :: HandleLike h => S.PartnerId -> TlsM h g () succWriteSn = modify . S.succWriteSN; succReadSn = modify . S.succReadSN++getCipherSuiteSt :: HandleLike h => S.PartnerId -> TlsM h g S.CipherSuite+getCipherSuiteSt = gets . S.getCipherSuite++setCipherSuiteSt :: HandleLike h => S.PartnerId -> S.CipherSuite -> TlsM h g ()+setCipherSuiteSt = (modify .) . S.setCipherSuite++setKeys :: HandleLike h => S.PartnerId -> S.Keys -> TlsM h g ()+setKeys = (modify .) . S.setKeys++getKeys :: HandleLike h => S.PartnerId -> TlsM h g S.Keys+getKeys = gets . S.getKeys++flushCipherSuiteRead, flushCipherSuiteWrite ::+	HandleLike h => S.PartnerId -> TlsM h g ()+flushCipherSuiteRead = modify . S.flushCipherSuiteRead+flushCipherSuiteWrite = modify . S.flushCipherSuiteWrite  withRandom :: HandleLike h => (gen -> (a, gen)) -> TlsM h gen a withRandom p = do