xml-push 0.0.0.9 → 0.0.0.10

raw patch · 10 files changed

+36/−29 lines, 10 files

Files

• examples/TestPusher.hs +20/−1
• examples/httpPullTlsCl.hs +1/−1
• examples/httpPushTlsE.hs +1/−1
• examples/httpPushTlsT.hs +2/−15
• examples/xmppTls.hs +1/−1
• src/Network/XmlPush/HttpPull/Tls/Client.hs +1/−1
• src/Network/XmlPush/HttpPush/Tls.hs +6/−6
• src/Network/XmlPush/Tls/Client.hs +1/−0
• src/Network/XmlPush/Xmpp/Tls.hs +1/−1
• xml-push.cabal +2/−2

@@ -1,16 +1,25 @@ {-# LANGUAGE TupleSections, TypeFamilies, FlexibleContexts #-} -module TestPusher (XmlPusher(..), Zero(..), One(..), Two(..), testPusher) where+module TestPusher (+	XmlPusher(..), Zero(..), One(..), Two(..),+	testPusher, checkFingerprint) where  import Control.Applicative import Control.Monad import Control.Concurrent import Data.Maybe+import Data.List+import Data.Char import Data.Pipe import Data.Pipe.ByteString+import Data.X509+import Data.X509.Validation import System.IO import Text.XML.Pipe+import Numeric +import qualified Data.ByteString as BS+ import Network.XmlPush  testPusher :: XmlPusher xp =>@@ -25,3 +34,13 @@ 		=$= convert fromJust 		=$= xmlNode [] 		=$= writeTo xp++checkFingerprint :: [String] -> SignedCertificate -> Bool+checkFingerprint fps c = cutFingerprint (getFingerprint c HashSHA256) `elem` fps++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

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

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

@@ -1,18 +1,13 @@ {-# 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@@ -29,7 +24,7 @@ 			(HttpPushTlsArgs 				(HttpPushArgs getClientHandle Nothing 					Nothing gtPth wntRspns)-				(tlsArgsCl "Yoshikuni" checkCertXml+				(tlsArgsCl "Yoshikuni" True checkCertXml 					["TLS_RSA_WITH_AES_128_CBC_SHA"] 						ca [(k', c')]) 				(tlsArgsSv gtNm (const Nothing)@@ -40,15 +35,7 @@ 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+checkCert = checkFingerprint ["81:9A:16:4A:57:AE:82:92:78:E0"]  getClientHandle :: XmlNode -> Maybe (IO Handle, String, Int, FilePath) getClientHandle (XmlNode (_, "client") [] [] [XmlCharData hn]) = Just (

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

@@ -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

@@ -40,7 +40,7 @@  type TlsArgsCl = TC.TlsArgs -tlsArgsCl :: String ->+tlsArgsCl :: String -> Bool -> 	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> 	[Cl.CipherSuite] -> CertificateStore -> 	[(CertSecretKey, CertificateChain)] -> TlsArgsCl@@ -79,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 cc' cs ca kcs) (TS.TlsArgs gn cc cs' mca' kcs')) = do+	(TC.TlsArgs dn cdn 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@@ -88,18 +88,18 @@ 		_ -> return () 	v <- liftBase . atomically $ newTVar False 	vhi <- liftBase . atomically $ newTVar hi-	(ci, co) <- clientC vch vhi cc' gp cs ca kcs+	(ci, co) <- clientC vch vhi cdn 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)) ->+	TVar (Maybe h) -> TVar (Maybe (String, Int, FilePath)) -> Bool -> 	(XmlNode -> Maybe (SignedCertificate -> Bool)) -> 	(XmlNode -> FilePath) -> 	[Cl.CipherSuite] -> CertificateStore -> 	[(CertSecretKey, CertificateChain)] -> 	HandleMonad h (TChan (XmlNode, Bool), TChan (Maybe XmlNode))-clientC vh vhi cc gp cs ca kcs = do+clientC vh vhi cdn cc gp cs ca kcs = do 	inc <- liftBase $ atomically newTChan 	otc <- liftBase $ atomically newTChan 	(g :: SystemRNG) <- liftBase $ cprgCreate <$> createEntropyPool@@ -115,7 +115,7 @@ 				Just hi -> return hi 				_ -> retry 		(`Cl.run` g) $ do-			t <- Cl.open h cs kcs ca+			t <- (if cdn then Cl.open' h hn else Cl.open h) cs kcs ca 			runPipe_ $ fromTChan otc 				=$= filter isJust 				=$= convert fromJust

@@ -9,6 +9,7 @@  data TlsArgs = TlsArgs { 	serverName :: String,+	checkServerName :: Bool, 	checkCertificate :: XmlNode -> Maybe (SignedCertificate -> Bool), 	cipherSuites :: [CipherSuite], 	certificateAuthorities :: CertificateStore,

@@ -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.9+version:	0.0.0.10 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.9+    tag:	xml-push-0.0.0.10  library     hs-source-dirs:	src