xml-push 0.0.0.8 → 0.0.0.9

raw patch · 11 files changed

+57/−16 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/httpPullTlsCl.hs +2/−1
• examples/httpPushTlsE.hs +2/−1
• examples/httpPushTlsT.hs +21/−1
• examples/xmppTls.hs +2/−1
• src/Network/XmlPush/HttpPull/Tls/Client.hs +1/−1
• src/Network/XmlPush/HttpPush.hs +1/−1
• src/Network/XmlPush/HttpPush/Common.hs +4/−2
• src/Network/XmlPush/HttpPush/Tls.hs +19/−5
• src/Network/XmlPush/Tls/Client.hs +2/−0
• src/Network/XmlPush/Xmpp/Tls.hs +1/−1
• xml-push.cabal +2/−2

@@ -17,7 +17,8 @@ 	testPusher (undefined :: HttpPullTlsCl Handle) (One h) (HttpPullTlsClArgs 		(HttpPullClArgs "localhost" 443 "/" gtPth mkPoll 			pendingQ (Just 10000000) drtn)-		(TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )+		(TlsArgs "localhost" (const Nothing)+			["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )  mkPoll :: IO XmlNode mkPoll = return $ XmlNode (nullQ "poll") [] [] []

@@ -19,7 +19,8 @@ 	testPusher (undefined :: HttpPushTls Handle) (Two (Just ch) Nothing) (HttpPushTlsArgs 		(HttpPushArgs (const Nothing) getServerHandle 			(Just ("localhost", 80, "")) gtPth wntRspns)-		(tlsArgsCl "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca+		(tlsArgsCl "localhost" (const Nothing)+			["TLS_RSA_WITH_AES_128_CBC_SHA"] ca 			[(k', c')]) 		(tlsArgsSv gtNm (const Nothing) 			["TLS_RSA_WITH_AES_128_CBC_SHA"]

@@ -1,12 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}  import Control.Monad+import Data.List+import Data.Char+import Data.X509+import Data.X509.Validation import System.IO import Text.XML.Pipe import Network import Network.XmlPush.HttpPush.Tls import Network.PeyoTLS.ReadFile+import Numeric +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC  import TestPusher@@ -23,12 +29,26 @@ 			(HttpPushTlsArgs 				(HttpPushArgs getClientHandle Nothing 					Nothing gtPth wntRspns)-				(tlsArgsCl "Yoshikuni"+				(tlsArgsCl "Yoshikuni" checkCertXml 					["TLS_RSA_WITH_AES_128_CBC_SHA"] 						ca [(k', c')]) 				(tlsArgsSv gtNm (const Nothing) 					["TLS_RSA_WITH_AES_128_CBC_SHA"] 					(Just ca) [(k', c')]) )++checkCertXml :: XmlNode -> Maybe (SignedCertificate -> Bool)+checkCertXml = const $ Just checkCert++checkCert :: SignedCertificate -> Bool+checkCert c = cutFingerprint (getFingerprint c HashSHA256) `elem` [+	"81:9A:16:4A:57:AE:82:92:78:E0" ]++cutFingerprint :: Fingerprint -> String+cutFingerprint (Fingerprint bs) = lastN 29 .+	intercalate ":" . map (map toUpper . flip showHex "") $ BS.unpack bs++lastN :: Int -> [a] -> [a]+lastN n xs = drop (length xs - n) xs  getClientHandle :: XmlNode -> Maybe (IO Handle, String, Int, FilePath) getClientHandle (XmlNode (_, "client") [] [] [XmlCharData hn]) = Just (

@@ -23,7 +23,8 @@ 	testPusher (undefined :: XmppTls Handle) (One h) (XmppTlsArgs 		(XmppArgs ["EXTERNAL", "SCRAM-SHA-1", "DIGEST-MD5", "PLAIN"] 			(toJid me) ps (toJid you) iNdRspns wntRspns)-		(TlsArgs "localhost" ["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )+		(TlsArgs "localhost" (const Nothing)+			["TLS_RSA_WITH_AES_128_CBC_SHA"] ca [(k, c)]) )  wntRspns :: XmlNode -> Bool wntRspns (XmlNode (_, "monologue") _ [] []) = False

@@ -77,7 +77,7 @@ makeHttpPull :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => 	One h -> HttpPullTlsClArgs h -> HandleMonad h (HttpPullTlsCl h) makeHttpPull (One h) (HttpPullTlsClArgs-	(HttpPullClArgs hn pn fp gp pl ip d gd) (TlsArgs dn cs ca kcs)) = do+	(HttpPullClArgs hn pn fp gp pl ip d gd) (TlsArgs dn _ cs ca kcs)) = do 	dr <- liftBase . atomically $ newTVar d 	(inc, otc) <- do 		(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool

@@ -78,7 +78,7 @@ 		runPipe_ $ fromTChan otc 			=$= filter isJust 			=$= convert fromJust-			=$= clientLoop h hn pn pt gp+			=$= clientLoop h hn pn pt gp (convert id) 			=$= convert (, False) 			=$= toTChan inc 	return (inc, otc)

@@ -38,8 +38,9 @@  clientLoop :: (HandleLike h, MonadBaseControl IO (HandleMonad h)) => 	h -> String -> Int -> FilePath -> (XmlNode -> FilePath) ->+	Pipe XmlNode XmlNode (HandleMonad h) () -> 	Pipe XmlNode XmlNode (HandleMonad h) ()-clientLoop h hn pn pt gp = (await >>=) . maybe (return ()) $ \n -> do+clientLoop h hn pn pt gp p = (await >>=) . maybe (return ()) $ \n -> do 	r <- lift . request h $ post hn pn (pt ++ "/" ++ gp n) 		(Nothing, LBS.fromChunks [xmlString [n]]) 	return ()@@ -47,7 +48,8 @@ 		=$= xmlEvent 		=$= convert fromJust 		=$= void (xmlNode [])-	clientLoop h hn pn pt gp+		=$= p+	clientLoop h hn pn pt gp p  checkReply :: MonadBase IO m => (XmlNode -> Bool) -> TChan (Maybe XmlNode) -> 	Pipe XmlNode (XmlNode, Bool) m ()

@@ -40,7 +40,9 @@  type TlsArgsCl = TC.TlsArgs -tlsArgsCl :: String -> [Cl.CipherSuite] -> CertificateStore ->+tlsArgsCl :: String ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	[Cl.CipherSuite] -> CertificateStore -> 	[(CertSecretKey, CertificateChain)] -> TlsArgsCl tlsArgsCl = TC.TlsArgs @@ -77,7 +79,7 @@ 	Maybe h -> Maybe h -> 	HttpPushTlsArgs h -> HandleMonad h (HttpPushTls h) makeHttpPushTls mch msh (HttpPushTlsArgs (HttpPushArgs gc gs hi gp wr)-	(TC.TlsArgs dn cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do+	(TC.TlsArgs dn cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do 	vch <- liftBase . atomically $ newTVar mch 	vsh <- liftBase . atomically $ newTVar msh 	case hi of@@ -86,17 +88,18 @@ 		_ -> return () 	v <- liftBase . atomically $ newTVar False 	vhi <- liftBase . atomically $ newTVar hi-	(ci, co) <- clientC vch vhi gp cs ca kcs+	(ci, co) <- clientC vch vhi cc' gp cs ca kcs 	(si, so) <- talk wr vsh gn cc cs' mca' kcs' vch vhi gc gs 	return $ HttpPushTls v ci co si so  clientC :: (ValidateHandle h, MonadBaseControl IO (HandleMonad h)) => 	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> 	(XmlNode -> FilePath) -> 	[Cl.CipherSuite] -> CertificateStore -> 	[(CertSecretKey, CertificateChain)] -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC vh vhi gp cs ca kcs = do+clientC vh vhi cc gp cs ca kcs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan 	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool@@ -116,7 +119,7 @@ 			runPipe_ $ fromTChan otc 				=$= filter isJust 				=$= convert fromJust-				=$= clientLoop t hn pn pt gp+				=$= clientLoop t hn pn pt gp (checkCertCl t cc) 				=$= convert (, False) 				=$= toTChan inc 	return (inc, otc)@@ -170,6 +173,17 @@ 	unless (ck c) $ error "checkCert: bad certificate" 	yield n 	checkCert t cc++checkCertCl :: (ValidateHandle h, CPRG g) => Cl.TlsHandle h g ->+	(XmlNode -> Maybe (SignedCertificate -> Bool)) ->+	Pipe XmlNode XmlNode (Cl.TlsM h g) ()+checkCertCl t cc = (await >>=) . maybe (return ()) $ \n -> do+	lift $ hlDebug t "medium" "begin checkCertCl"+	let ck = maybe (const True) id $ cc n+	c <- lift $ Cl.getCertificate t+	unless (ck c) $ error "checkCert: bad certificate"+	yield n+	checkCertCl t cc  checkName :: HandleLike h => Sv.TlsHandle h g -> (XmlNode -> Maybe String) -> 	Pipe XmlNode XmlNode (Sv.TlsM h g) ()

@@ -5,9 +5,11 @@ import Data.X509 import Data.X509.CertificateStore import Network.PeyoTLS.Client+import Text.XML.Pipe  data TlsArgs = TlsArgs { 	serverName :: String,+	checkCertificate :: XmlNode -> Maybe (SignedCertificate -> Bool), 	cipherSuites :: [CipherSuite], 	certificateAuthorities :: CertificateStore, 	keyChains :: [(CertSecretKey, CertificateChain)]

@@ -56,7 +56,7 @@ 	MonadError (HandleMonad h), Error (ErrorType (HandleMonad h)) 	) => One h -> XmppTlsArgs h -> HandleMonad h (XmppTls h) makeXmppTls (One h)-	(XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn cs ca kcs)) = do+	(XmppTlsArgs (XmppArgs ms me ps you inr wr) (TlsArgs dn _ cs ca kcs)) = do 	nr <- liftBase $ atomically newTChan 	wc <- liftBase $ atomically newTChan 	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool

@@ -2,7 +2,7 @@ cabal-version:	>= 1.8  name:		xml-push-version:	0.0.0.8+version:	0.0.0.9 stability:	Experimenmtal author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -100,7 +100,7 @@ source-repository	this     type:	git     location:	git://github.com/YoshikuniJujo/xml-push.git-    tag:	xml-push-0.0.0.8+    tag:	xml-push-0.0.0.9  library     hs-source-dirs:	src